diff options
Diffstat (limited to 'sys/nmemio')
| -rw-r--r-- | sys/nmemio/README | 1 | ||||
| -rw-r--r-- | sys/nmemio/begmem.x | 65 | ||||
| -rw-r--r-- | sys/nmemio/calloc.x | 20 | ||||
| -rw-r--r-- | sys/nmemio/coerce.x | 25 | ||||
| -rw-r--r-- | sys/nmemio/doc/memio.hlp | 308 | ||||
| -rw-r--r-- | sys/nmemio/kmalloc.x | 21 | ||||
| -rw-r--r-- | sys/nmemio/krealloc.x | 110 | ||||
| -rw-r--r-- | sys/nmemio/main.x | 893 | ||||
| -rw-r--r-- | sys/nmemio/malloc.x | 24 | ||||
| -rw-r--r-- | sys/nmemio/malloc1.x | 130 | ||||
| -rw-r--r-- | sys/nmemio/merror.x | 18 | ||||
| -rw-r--r-- | sys/nmemio/mfini.x | 57 | ||||
| -rw-r--r-- | sys/nmemio/mfree.x | 118 | ||||
| -rw-r--r-- | sys/nmemio/mgc.x | 222 | ||||
| -rw-r--r-- | sys/nmemio/mgdptr.x | 33 | ||||
| -rw-r--r-- | sys/nmemio/mgtfwa.x | 27 | ||||
| -rw-r--r-- | sys/nmemio/mgtlwl.x | 18 | ||||
| -rw-r--r-- | sys/nmemio/minit.x | 127 | ||||
| -rw-r--r-- | sys/nmemio/mkpkg | 31 | ||||
| -rw-r--r-- | sys/nmemio/msvfwa.x | 55 | ||||
| -rw-r--r-- | sys/nmemio/nmemio.com | 26 | ||||
| -rw-r--r-- | sys/nmemio/realloc.x | 22 | ||||
| -rw-r--r-- | sys/nmemio/salloc.x | 155 | ||||
| -rw-r--r-- | sys/nmemio/sizeof.x | 12 | ||||
| -rw-r--r-- | sys/nmemio/vmalloc.x | 28 | ||||
| -rw-r--r-- | sys/nmemio/zz.x | 11 | ||||
| -rw-r--r-- | sys/nmemio/zzdebug.x | 86 | ||||
| -rw-r--r-- | sys/nmemio/zzfoo.gx | 587 | ||||
| -rw-r--r-- | sys/nmemio/zzfoo.x | 908 |
29 files changed, 4138 insertions, 0 deletions
diff --git a/sys/nmemio/README b/sys/nmemio/README new file mode 100644 index 00000000..597f1114 --- /dev/null +++ b/sys/nmemio/README @@ -0,0 +1 @@ +MEMIO -- Memory allocation and management facilities. diff --git a/sys/nmemio/begmem.x b/sys/nmemio/begmem.x new file mode 100644 index 00000000..e61f6e1e --- /dev/null +++ b/sys/nmemio/begmem.x @@ -0,0 +1,65 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help begmem, fixmem +.nf ___________________________________________________________________________ +BEGMEM, FIXMEM -- Try to get/release physical memory for a process. The +actual amount of physical memory available (in chars) is returned. On a +machine with virtual memory, these routines adjust the working set size. + +On any machine, BEGMEM may be used to determine the amount of available +physical memory, to tune algorithms for optimum performance. BEGMEM returns +as its function value the actual working set size of the process after +the adjustment (or the current working set size if "best_size" is zero). +On some systems this represents a soft limit on the actual amount of memory +which can be used; it is a guarantee that at least that much space is +available. Some systems will allow the actual working set to dynamically +exceed this value at runtime if the process pages heavily. The hard limit +on the working set of a process is given by the "max_size" parameter. + +Note that the working set must include space not only for a task specific +data buffers, but also for all other process data buffers and for the text +(instruction space) of the code being executed. There is no easy way to +determine this, hence the application is expected to estimate it. A typical +value for the base text+data size required to execute a program is 150Kb. +.endhelp ______________________________________________________________________ + + +# BEGMEM -- Attempt to the adjust the amount of physical memory allocated +# to a process. Save the old memory size in OLD_SIZE, so that memory may +# later be restored with FIXMEM. The new working set size is returned as +# the function value and the hard limit on the working set size is returned +# in MAX_SIZE. In general, the process can be expected to page, possibly +# heavily, or swap out if the working set size is exceeded. All sizes are +# returned in SPP chars. If BEST_SIZE is zero the working set size is not +# changed, i.e., the current working set parameters are returned. + +int procedure begmem (best_size, old_size, max_size) + +int best_size # desired working set size +int old_size # former working set size +int max_size # max physical memory available to this process + +int new_size + +begin + call zawset (best_size * SZB_CHAR, new_size, old_size, max_size) + new_size = new_size / SZB_CHAR + old_size = old_size / SZB_CHAR + max_size = max_size / SZB_CHAR + + return (new_size) +end + + +# FIXMEM -- Restore the original working set size. + +procedure fixmem (old_size) + +int old_size +int j1, j2, j3 + +begin + call zawset (old_size * SZB_CHAR, j1, j2, j3) +end diff --git a/sys/nmemio/calloc.x b/sys/nmemio/calloc.x new file mode 100644 index 00000000..c1b7ffb4 --- /dev/null +++ b/sys/nmemio/calloc.x @@ -0,0 +1,20 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# CALLOC -- Allocate and zero a block of memory. + +procedure calloc (ubufp, buflen, dtype) + +pointer ubufp # user buffer pointer [OUTPUT] +int buflen # nelements of space required, +int dtype # of this data type + +pointer char_ptr +pointer coerce() +int sizeof() +errchk malloc + +begin + call malloc (ubufp, buflen, dtype) + char_ptr = coerce (ubufp, dtype, TY_CHAR) + call aclrc (Memc[char_ptr], buflen * sizeof (dtype)) +end diff --git a/sys/nmemio/coerce.x b/sys/nmemio/coerce.x new file mode 100644 index 00000000..36f762b2 --- /dev/null +++ b/sys/nmemio/coerce.x @@ -0,0 +1,25 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# COERCE -- Coerce a pointer from one datatype to another, choosing the +# next larger element for t2 in the event that t1 is not aligned with t2. + +pointer procedure coerce (ptr, type1, type2) + +pointer ptr # input pointer +int type1, type2 # from, to data types +int n +pointer p +include <szdtype.inc> + +begin + p = ptr - 1 + if (type1 == TY_CHAR) { + return (p / ty_size[type2] + 1) + } else if (type2 == TY_CHAR) { + return (p * ty_size[type1] + 1) + } else { + p = p * ty_size[type1] # ptr to char + n = ty_size[type2] + return (((p + n-1) / n) + 1) + } +end diff --git a/sys/nmemio/doc/memio.hlp b/sys/nmemio/doc/memio.hlp new file mode 100644 index 00000000..1bc5c0a0 --- /dev/null +++ b/sys/nmemio/doc/memio.hlp @@ -0,0 +1,308 @@ +.help memio Feb83 "Dynamic Memory Management Routines" +.sh +Introduction + + The memory management routines manage both a stack and a heap. +Storage for the stack may be fragmented, and chunks of stack storage are +allocated dynamically from the heap as needed. Programs may allocate +heap storage directly if desired, for large or semipermanent buffers. +Stack storage is intended for use with small buffers, where the overhead +of allocating and deallocating space must be kept to a minimum. + + +.ks +.nf +heap routines: + + malloc (ptr, number_of_elements, data_type) + calloc (ptr, number_of_elements, data_type) + realloc (ptr, number_of_elements, data_type) + mfree (ptr, data_type) + + +stack routines: + + salloc (ptr, number_of_elements, data_type) + smark (ptr) + sfree (ptr) +.fi +.ke + + +MALLOC allocates space on the heap. CALLOC does the same, and fills the buffer +with zeroes. REALLOC is used to change the size of a previously allocated +buffer, copying the contents of the buffer if necessary. MFREE frees space +allocated by a prior call to MALLOC, CALLOC, or REALLOC. + +Space is allocated on the stack with SALLOC. SMARK should be called before +SALLOC, to mark the position of the stack pointer. SFREE returns all space +allocated on the stack since the matching call to SMARK. + + +.KS +Example: +.nf + pointer buf, sp + + begin + call smark (sp) + call salloc (buf, SZ_BUF, TY_CHAR) + while (getline (fd, Memc[buf]) != EOF) { + (code to use buffer ...) + } + call sfree (sp) +.fi +.KE + + +These routines will generate an error abort if memory cannot be allocated +for some reason. + +.sh +Heap Management + + Since many operating systems provide heap management facilities, +MALLOC and MFREE consist of little more than calls to Z routines to +allocate and free blocks of memory. The main function of MALLOC is +to convert the physical buffer address returned by the Z routine into +a pointer of the requested type. + +The pointer returned to the calling routine does not point at the beginning +of the physical buffer, but at a location a few bytes into the buffer. +The physical address of the buffer is stored in the buffer, immediately +before the cell pointed to by the pointer returned by MALLOC. The +stored address must be intact when MFREE is later called to deallocate +the buffer, or a "Memory corrupted" error diagnostic will result. + +The Z routines required to manage the heap are the following: + +.KS +.nf + zmget (bufadr, nbytes) + zmrget (bufadr, nbytes) + zmfree (buf_addr) +.fi +.KE + +The "get" routines should return NULL as the buffer address if space +cannot be allocated for some reason. + +.sh +Stack Management + + The heap management routines have quite a bit of overhead associated +with them, which precludes their use in certain applications. In addition, +the heap can be most efficiently managed when it contains few buffers. +The stack provides an efficient mechanism for parceling out small amounts +of storage, which can later all be freed with a single call. + +The main use of the stack is to provide automatic storage for local +arrays in procedures. The preprocessor compiles code which makes calls +to the stack management routines whenever an array is declared with the +storage calls AUTO, or whenever the ALLOC statement is used in a procedure. + + +.KS +.nf + auto char lbuf[SZ_LINE] + real x[n], y[n] + int n + + begin + alloc (x[npix], y[npix]) + + while (getline (fd, lbuf) != EOF) { + ... +.fi +.KE + + +The AUTO storage class and the ALLOC statement are provided in the full +preprocessor, but not in the subset preprocessor. The following subset +preprocessor code is functionally equivalent to the code show above: + + +.KS +.nf + pointer lbuf, x, y, sp + int n, getline() + + begin + call smark (sp) + call salloc (lbuf, SZ_LINE, TY_CHAR) + n = npix + call salloc (x, n, TY_REAL) + call salloc (y, n, TY_REAL) + + while (getline (fd, Memc[lbuf]) != EOF) { + ... + + call sfree (sp) +.fi +.KE + +.sh +Semicode for Stack Management + + At any given time, the "stack" is a contiguous buffer of a certain size. +Stack overflow is handled by calling MALLOC to allocate another stack segment. +A pointer to the previous stack segment is kept in each new stack segment, +to permit reclamation of stack space. + + + + +.KS +.nf + salloc smark sfree + + + + stack_overflow + + + + malloc realloc mfree + + + + zmget zmrget zmfree + + + + Structure of the Memory Management Routines +.fi +.KE + + + + +.tp 5 +.nf +procedure salloc (bufptr, nelements, data_type) + +bufptr: upon output, contains pointer to the allocated space +nelements: number of elements of space to be allocated +data_type: data type of the elements and of the buffer pointer + +begin + # align stack pointer for the specified data type, + # compute amount of storage to be allocated + + if (data_type == TY_CHAR) + nchars = nelements + else { + sp = sp + mod (sp-1, sizeof(data_type)) + nchars = nelements * sizeof(data_type) + } + + if (sp + nchars > stack_top) # see if room + call stack_overflow (nchars) + + if (data_type == TY_CHAR) # return pointer + bufptr = sp + else + bufptr = (sp-1) / sizeof(data_type) + 1 + + sp = sp + nchars # bump stack ptr + return +end + + + + +.tp 5 +procedure sfree (old_sp) # pop the stack + +begin + # return entire segments until segment containing the old + # stack pointer is reached + + while (old_sp < stack_base || old_sp > stack_top) { + if (this is the first stack segment) + fatal error, invalid value for old_sp + stack_base = old_segment.stack_base + stack_top = old_segment.stack_top + mfree (segment_pointer, TY_CHAR) + segment_pointer = old_segment + } + + sp = old_sp +end + + + + +.tp 5 +procedure smark (old_sp) # save stack pointer + +begin + old_sp = sp +end + + + + +.tp 5 +procedure stack_overflow (nchars_needed) # increase stk size + +begin + # allocate storage for new segment + segment_size = max (SZ_STACK, nchars_needed + SZ_STKHDR) + malloc (new_segment, segment_size, TY_CHAR) + + # initialize header for the new segment + new_segment.old_segment = segment_pointer + new_segment.stack_base = new_segment + SZ_STKHDR + new_segment.stack_top = new_segment + segment_size + + # make new segment the current segment + segment_pointer = new_segment + stack_base = new_segment.stack_base + stack_top = new_segment.stack_top + sp = stack_base +end + + +.fi +The segment header contains fields describing the location and size of +the segment, plus a link pointer to the previous segment in the list. + + +.KS +.nf + struct stack_header { + char *stack_base + char *stack_top + struct stack_header *old_segment + } +.fi +.KE + +.sh +Pointers and Addresses + + Pointers are indices into (one indexed) Fortran arrays. A pointer to +an object of one datatype will in general have a different value than a +pointer to an object of a different datatype, even if the objects are stored +at the same physical address. Pointers have strict alignment requirements, +and it is not always possible to coerce the type of a pointer. For this +reason, the pointers returned by MALLOC and SALLOC are always aligned for +all data types, regardless of the data type requested. + +The IRAF system code must occasionally manipulate and store true physical +addresses, obtained with the function LOC. The problem with physical +addresses is that they are unsigned integers, but Fortran does not provide +any unsigned data types. Thus, comparisons of addresses are difficult +in Fortran. + +A second LOC primitive is provided for use in routines which must compare +addresses. LOCC returns the address of the object passed as argument, +right shifted to the size of a CHAR. Thus, the difference between LOCC(a[1]) +and LOCC(a[n]) is the size of the N element array A in chars. + +The relationship between chars, bytes, and machine addresses is machine +dependent. Bytes seem to be the smallest units. Some machines are byte +addressable, others are word addressable. The size of a CHAR in machine +bytes is given by the constant SZB_CHAR. The size of a machine word in +machine bytes is given by the constant SZB_WORD. diff --git a/sys/nmemio/kmalloc.x b/sys/nmemio/kmalloc.x new file mode 100644 index 00000000..7bfc4ee0 --- /dev/null +++ b/sys/nmemio/kmalloc.x @@ -0,0 +1,21 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <config.h> + +# KMALLOC -- Allocate space on the heap. Equivalent to MALLOC, except that a +# memory allocation failure is indicated by returning ERR as the function value. + +int procedure kmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + return (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align)) +end diff --git a/sys/nmemio/krealloc.x b/sys/nmemio/krealloc.x new file mode 100644 index 00000000..be080547 --- /dev/null +++ b/sys/nmemio/krealloc.x @@ -0,0 +1,110 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <config.h> +include <syserr.h> + +# KREALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. This routine is equivalent to REALLOC except that it +# merely returns ERR as the function value if an error occurs. +# +# Buffer reallocation or resizing can always be implemented by allocating a new +# buffer, copying the contents of the old buffer to the new buffer, and then +# deleting the old buffer. Nonetheless we use a OS entry point to do the actual +# reallocation, because often it will be possible to change the size of a buffer +# without moving it, particularly when decreasing the size of the buffer. +# +# Allowing the OS to move a buffer causes problems due to the difference in +# alignment criteria imposed by the IRAF pointer scheme, which enforces +# stringent alignment criteria, versus OS memory allocation schemes which +# typically only align on word or longword boundaries. Therefore we must +# check the offset of the data area after reallocation, possibly shifting +# the contents of data area up or down a few chars to reestablish alignment +# with Mem. + +int procedure krealloc (ptr, a_nelems, a_dtype) + +pointer ptr # buffer to be reallocated +int a_nelems # new size of buffer +int a_dtype # buffer datatype + +pointer dataptr +int nelems, dtype, nchars, nuser, old_fwa, new_fwa +int char_shift, old_char_offset, new_char_offset +int status, locbuf, loc_Mem + +int mgtfwa(), sizeof(), kmalloc() +pointer mgdptr(), msvfwa(), coerce() +data loc_Mem /NULL/ + +begin + # Copy over the number of elements and the data type in case they are + # located in the block of memory we are reallocating. + + nelems = a_nelems + dtype = a_dtype + + if (ptr == NULL) { + return (kmalloc (ptr, nelems, dtype)) + + } else { + if (dtype == TY_CHAR) + nuser = nelems + 1 + else + nuser = nelems * sizeof(dtype) + 1 + + nchars = nuser + (8 * SZ_INT) + SZ_MEMALIGN + old_fwa = mgtfwa (ptr, dtype) + new_fwa = old_fwa + + # Change the buffer size; any error is fatal. + call zraloc (new_fwa, nchars * SZB_CHAR, status) + if (status == ERR) { + call merror ("Realloc failed\n") + ptr = NULL + return (ERR) + } + + # Compute the char offset of the old data area within the original + # buffer; zraloc() guarantees that the old data will have the same + # offset in the new buffer. Compute the char offset of the new + # data area. These need not be the same due to the OS allocating + # the new buffer to alignment criteria less than those required + # by MEMIO. + + call zlocva (Memc[coerce(ptr,dtype,TY_CHAR)], locbuf) + old_char_offset = (locbuf - old_fwa) + + # We must compute a pointer to the data area within the new + # buffer before we can compute the char offset of the new data + # area within the new buffer. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + + dataptr = mgdptr (new_fwa, TY_CHAR, SZ_MEMALIGN, loc_Mem) + call zlocva (Memc[dataptr], locbuf) + new_char_offset = (locbuf - new_fwa) + + # Shift the old data to satisfy the new alignment criteria, + # if necessary. + # + # FIXME -- If the new alloation is smaller than the old pointer, + # we should only copy as much data as will fit in the + # new space as per normal unix handling. + + char_shift = (new_char_offset - old_char_offset) + if (char_shift != 0) { + call amovc (Memc[dataptr - char_shift], Memc[dataptr], + nelems * sizeof(dtype)) + } + + # Save the fwa of the OS buffer in the buffer header, and return + # new pointer to user. + + ptr = msvfwa (new_fwa, dtype, nelems, SZ_MEMALIGN, loc_Mem) + } + + return (OK) +end diff --git a/sys/nmemio/main.x b/sys/nmemio/main.x new file mode 100644 index 00000000..653023ed --- /dev/null +++ b/sys/nmemio/main.x @@ -0,0 +1,893 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <config.h> +include <error.h> +include <syserr.h> +include <clset.h> +include <fset.h> +include <ctype.h> +include <printf.h> +include <xwhen.h> +include <knet.h> + +.help iraf_main +.nf __________________________________________________________________________ +The IRAF MAIN + + Task resident interpreter for interface to CL. Supervises process startup +and shutdown, error restart, and task execution. A process may contain any +number of tasks, which need not be related. The iraf main allows a process to +be run either directly (interactively or in batch) or from the CL. A brief +description of the operation of the Main is given here; additional documentation +is given in the System Interface Reference Manual. + + +EXECUTION + +[1] The process containing the IRAF Main is run. The PROCESS MAIN, a machine + dependent code segment, gains control initially. The process main + determines whether the task is being run from as a connected subprocess, + as a detached process, or as a host process, and opens the process + standard i/o channels. The process main then calls the IRAF Main, i.e., us. + +[2] The IRAF Main performs the initialization associated with process startup + and then enters the interpreter loop waiting for a command. A number of + special commands are implemented, e.g.: + + ? print menu + bye shutdown process + chdir change directory + set set environment variable or variables + + Any other command is assumed to be the name of a task. The syntax of a + task invocation statement is as follows: + + [$]task [<[fname]], ([[stream[(T|B)]]>[fname]])|([[stream]>>[fname]]) + + Everything but the task name is optional. A leading $ enables printing of + the cpu time and clock time consumed by the process at termination. Any + combination of the standard i/o streams may be redirected on the command + line into a file. If the stream is redirected at the CL level redirection + is shown on the command line but the filename is omitted. + +[3] The communications protocol during task execution varies depending on + whether or not we are talking to the CL. If talking directly to the user, + the interpreter generates a prompt, and the standard input and output is + not blocked into XMIT and XFER commands. Interactive parameter requests + have the form "paramname: response" while CL/IPC requests have the form + "paramname=\nresponse", where "response" is the value entered by the user. + +[4] Task termination is indicated in interactive mode by generation of a prompt + for the next command and in CL/IPC mode by transmission of the command + "bye" to the parent process. If a task terminates abnormally the command + "error" is sent to the parent process or the terminal, and the Main reenters + the interpreter loop. + +A unique SYS_RUNTASK procedure is generated for each process at compile time by +performing string substitution on a TASK statement appearing in the source code. +The SYS_RUNTASK procedure contains the task dictionary, CALL statements for +each task, plus the special task "?". The main itself, i.e. this file, is a +precompiled library procedure which has no direct knowledge of the commands +to be run. + + +ERROR RECOVERY + + If a task terminates abnormally two things can happen: [1] a panic abort +occurs, causing immediate shutdown of the process (rare), or [2] the IRAF Main +is reentered at the ZSVJMP statement by a corresponding call to ZDOJMP from +elsewhere in the system, e.g., ERRACT in the error handling code. + +Error restart consists of the following steps: + + (1) The IRAF main is reentered at the point just after the ZDOJMP statement, + with a nonzero error code identifying the error in STATUS. + (2) The main performs error recovery, cleaning up the files system (deleting + NEW_FILES and TEMP_FILES), clearing the stack, and calling any + procedures posted with ONERROR. At present the error recovery code does + not free heap buffers or clear posted exception handlers. + (3) The ERROR statement is sent to the CL. An example of the + error statment is "ERROR (501, "Access Violation")". + (4) The main reenters the interpreter loop awaiting the next command from + the CL. + +Any error occuring during error restart is fatal and results in immediate +process termination, usually with a panic error message. This is necessary +to prevent infinite error recursion. + + +SHUTDOWN + + The process does not shutdown when interrupted by the CL or during error +recovery, unless a panic occurs. In normal operation shutdown only occurs when +the command BYE is received from the parennt process, or when EOF is read from +the process standard input. Procedures posted during execution with ONEXIT +will be called during process shutdown. Any error occuring while executing +an ONEXIT procedure is fatal and will result in a panic abort of the process. +.endhelp _____________________________________________________________________ + +define SZ_VALSTR SZ_COMMAND +define SZ_CMDBUF (SZ_COMMAND+1024) +define SZ_TASKNAME 32 +define TIMEIT_CHAR '$' +define MAXFD 5 # max redirectable fd's +define STARTUP 0 # stages of execution +define SHUTDOWN 1 +define IDLE 2 +define EXECUTING 3 +define DUMMY finit # any procedure will do + + +# IRAF_MAIN -- Execute commands read from the standard input until the special +# command "bye" is received, initiating process shutdown. The arguments tell +# the process type (connected, detached, or host) and identify the process +# standard i/o channels and device driver to be used. + +int procedure iraf_main (a_cmd, a_inchan, a_outchan, a_errchan, + a_driver, a_devtype, prtype, bkgfile, jobcode, sys_runtask, onentry) + +char a_cmd[ARB] # command to be executed or null string +int a_inchan # process standard input +int a_outchan # process standard output +int a_errchan # process standard error output +int a_driver # ZLOCPR address of device driver +int a_devtype # device type (text or binary) +int prtype # process type (connected, detached, host) +char bkgfile[ARB] # packed filename of bkg file if detached +int jobcode # jobcode if detached process +extern sys_runtask() # client task execution procedure +extern onentry() # client onentry procedure + +bool networking +int inchan, outchan, errchan, driver, devtype +char cmd[SZ_CMDBUF], taskname[SZ_TASKNAME], bkgfname[SZ_FNAME] +int arglist_offset, timeit, junk, interactive, builtin_task, cmdin +int jumpbuf[LEN_JUMPBUF], status, errstat, state, interpret, i +long save_time[2] +pointer sp + +bool streq() +extern DUMMY() +int sys_getcommand(), sys_runtask(), oscmd() +int access(), envscan(), onentry(), stropen() +errchk xonerror, fio_cleanup +common /JUMPCOM/ jumpbuf +string nullfile "dev$null" +data networking /KNET/ +define shutdown_ 91 + +# The following common is required on VMS systems to defeat the Fortran +# optimizer, which would otherwise produce optimizations that would cause +# a future return from ZSVJMP to fail. Beware that this trick may fail on +# other systems with clever optimizers. + +common /zzfakecom/ state + +begin + # The following initialization code is executed upon process + # startup only. + + errstat = OK + state = STARTUP + call mio_init() + call zsvjmp (jumpbuf, status) + if (status != OK) + call sys_panic (EA_FATAL, "fatal error during process startup") + + # Install the standard exception handlers, but if we are a connected + # subprocess do not enable interrupts until process startup has + # completed. + + call ma_ideh() + if (prtype == PR_CONNECTED) + call intr_disable() + + inchan = a_inchan + outchan = a_outchan + errchan = a_errchan + driver = a_driver + devtype = a_devtype + + # If the system is configured with networking initialize the network + # interface and convert the input channel codes and device driver + # code to their network equivalents. + + if (networking) + call ki_init (inchan, outchan, errchan, driver, devtype) + + # Other initializations. + call env_init() + call fmt_init (FMT_INITIALIZE) # init printf + call xer_reset() # init error checking + call erract (OK) # init error handling + call onerror (DUMMY) # init onerror + call onexit (DUMMY) # init onexit + call finit() # initialize FIO + call clopen (inchan, outchan, errchan, driver, devtype) + call clseti (CL_PRTYPE, prtype) + call clc_init() # init param cache + call strupk (bkgfile, bkgfname, SZ_FNAME) + + # If we are running as a host process (no IRAF parent process) look + # for the file "zzsetenv.def" in the current directory and then in + # the system library, and initialize the environment from this file + # if found. This works because the variable "iraf$" is defined at + # the ZGTENV level. + + interactive = NO + if (prtype == PR_HOST) { + interactive = YES + if (access ("zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @zzsetenv.def")) + ; + } else if (access ("host$hlib/zzsetenv.def",0,0) == YES) { + iferr (junk = envscan ("set @host$hlib/zzsetenv.def")) + ; + } + } + + # Save context for error restart. If an error occurs execution + # resumes just past the ZSVJMP statement with a nonzero status. + + call smark (sp) + call zsvjmp (jumpbuf, status) + + if (status != OK) { + errstat = status + + # Give up if error occurs during shutdown. + if (state == SHUTDOWN) + call sys_panic (errstat, "fatal error during process shutdown") + + # Tell error handling package that an error restart is in + # progress (necessary to avoid recursion). + + call erract (EA_RESTART) + + iferr { + # Call user cleanup routines and then clean up files system. + # Make sure that user cleanup routines are called FIRST. + + call xonerror (status) + call ma_ideh() + call flush (STDERR) + do i = CLIN, STDPLOT + call fseti (i, F_CANCEL, OK) + call fio_cleanup (status) + call fmt_init (FMT_INITIALIZE) + call sfree (sp) + } then + call erract (EA_FATAL) # panic abort + + # Send ERROR statement to the CL, telling the CL that the task + # has terminated abnormally. The CL will either kill us, resulting + # in error restart with status=SYS_XINT, or send us another command + # to execute. If we are connected but idle, do not send the ERROR + # statement because the CL will not read it until it executes the + # next task (which it will then mistakenly think has aborted). + + if (!(prtype == PR_CONNECTED && state == IDLE)) + call xer_send_error_statement_to_cl (status) + + # Inform error handling code that error restart has completed, + # or next error call will result in a panic shutdown. + + call erract (OK) + call xer_reset () + status = OK + } + + # During process startup and shutdown the parent is not listening to + # us, hence we dump STDOUT and STDERR into the null file. If this is + # not done and we write to CLOUT, deadlock may occur. During startup + # we also call the ONENTRY procedure. This is a no-op for connected + # and host subprocesses unless a special procedure is linked by the + # user (for detached processes the standard ONENTRY procedure opens + # the bkgfile as CLIN). The return value of ONENTRY determines whether + # the interpreter loop is entered. Note that ONENTRY permits complete + # bypass of the standard interpreter loop by an application (e.g. the + # IRAF CL). + + if (state == STARTUP) { + # Redirect stderr and stdout to the null file. + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } + + # Call the custom or default ONENTRY procedure. The lowest bit + # of the return value contains the PR_EXIT/PR_NOEXIT flag, higher + # bits may contain a more meaningful 7-bit status code which will + # be returned to the shell. + + i = onentry (prtype, bkgfname, a_cmd) + if (mod(i, 2) == PR_EXIT) { + interpret = NO + errstat = i / 2 + goto shutdown_ + } else + interpret = YES + + # Open the command input stream. If a command string was given on + # the command line then we read commands from that, otherwise we + # take commands from CLIN. + + for (i=1; IS_WHITE(a_cmd[i]) || a_cmd[i] == '\n'; i=i+1) + ; + if (a_cmd[i] != EOS) { + cmdin = stropen (a_cmd, ARB, READ_ONLY) + call fseti (cmdin, F_KEEP, YES) + interpret = NO + interactive = NO + } else + cmdin = CLIN + } + + # Interpreter loop of the IRAF Main. Execute named tasks until the + # command "bye" is received, or EOF is read on the process standard + # input (CLIN). Prompts and other perturbations in the CL/IPC protocol + # are generated if we are being run directly as a host process. + + while (sys_getcommand (cmdin, cmd, taskname, arglist_offset, + timeit, prtype) != EOF) { + + builtin_task = NO + if (streq (taskname, "bye")) { + # Initiate process shutdown. + break + } else if (streq (taskname, "set") || streq (taskname, "reset")) { + builtin_task = YES + } else if (streq (taskname, "cd") || streq (taskname, "chdir")) { + builtin_task = YES + } else if (prtype == PR_CONNECTED && streq (taskname, "_go_")) { + # Restore the normal standard output streams, following + # completion of process startup. Reenable interrupts. + call close (STDOUT) + call close (STDERR) + call intr_enable() + state = IDLE + next + } else if (taskname[1] == '!') { + # Send a command to the host system. + junk = oscmd (cmd[arglist_offset], "", "", "") + next + } else + state = EXECUTING + + if (builtin_task == NO) { + if (timeit == YES) + call sys_mtime (save_time) + + # Clear the parameter cache. + call clc_init() + + # Set the name of the root pset. + call clc_newtask (taskname) + + # Process the argument list, consisting of any mixture of + # parameter=value directives and i/o redirection directives. + + call sys_scanarglist (cmdin, cmd[arglist_offset]) + } + + # Call sys_runtask (the code for which was generated automatically + # by the preprocessor in place of the TASK statement) to search + # the dictionary and run the named task. + + errstat = OK + call mem_init (taskname) + if (sys_runtask (taskname,cmd,arglist_offset,interactive) == ERR) { + call flush (STDOUT) + call sprintf (cmd, SZ_CMDBUF, + "ERROR (0, \"Iraf Main: Unknown task name (%s)\")\n") + call pargstr (taskname) + call putline (CLOUT, cmd) + call flush (CLOUT) + state = IDLE + next + } + call mem_fini (taskname) + + # Cleanup after successful termination of command. Flush the + # standard output, cancel any unread standard input so the next + # task won't try to read it, print elapsed time if enabled, + # check for an incorrect error handler, call any user posted + # termination procedures, close open files, close any redirected + # i/o and restore the normal standard i/o streams. + + if (builtin_task == NO) { + + call flush (STDOUT) + call fseti (STDIN, F_CANCEL, OK) + + if (timeit == YES) + call sys_ptime (STDERR, taskname, save_time) + + call xer_verify() + call xonerror (OK) + call fio_cleanup (OK) + + if (prtype == PR_CONNECTED) { + call putline (CLOUT, "bye\n") + call flush (CLOUT) + } + if (state != STARTUP) + state = IDLE + } + } + + # The interpreter has exited after receipt of "bye" or EOF. Redirect + # stdout and stderr to the null file (since the parent is no longer + # listening to us), call the user exit procedures if any, and exit. + +shutdown_ + state = SHUTDOWN + if (prtype == PR_CONNECTED) { + call fredir (STDOUT, nullfile, WRITE_ONLY, TEXT_FILE) + call fredir (STDERR, nullfile, WRITE_ONLY, TEXT_FILE) + } else if (prtype == PR_HOST && cmd[1] == EOS && interpret == YES) { + call putci (CLOUT, '\n') + call flush (CLOUT) + } + + call xonexit (OK) + call fio_cleanup (OK) + call clclose() + + return (errstat) +end + + +# SYS_GETCOMMAND -- Get the next command from the input file. Ignore blank +# lines and comment lines. Parse the command and return the components as +# output arguments. EOF is returned as the function value when eof file is +# reached on the input file. + +int procedure sys_getcommand (fd, cmd, taskname, arglist_offset, timeit, prtype) + +int fd #I command input file +char cmd[SZ_CMDBUF] #O command line +char taskname[SZ_TASKNAME] #O extracted taskname, lower case +int arglist_offset #O offset into CMD of first argument +int timeit #O if YES, time the command +int prtype #I process type code + +int ip, op +int getlline(), stridx() + +begin + repeat { + # Get command line. Issue prompt first if process is being run + # interactively. + + if (prtype == PR_HOST && fd == CLIN) { + call putline (CLOUT, "> ") + call flush (CLOUT) + } + if (getlline (fd, cmd, SZ_CMDBUF) == EOF) + return (EOF) + + # Check for timeit character and advance to first character of + # the task name. + + timeit = NO + for (ip=1; cmd[ip] != EOS; ip=ip+1) { + if (cmd[ip] == TIMEIT_CHAR && timeit == NO) + timeit = YES + else if (!IS_WHITE (cmd[ip])) + break + } + + # Skip blank lines and comment lines. + switch (cmd[ip]) { + case '#', '\n', EOS: + next + case '?', '!': + taskname[1] = cmd[ip] + taskname[2] = EOS + arglist_offset = ip + 1 + return (OK) + } + + # Extract task name. + op = 1 + while (IS_ALNUM (cmd[ip]) || stridx (cmd[ip], "_.$") > 0) { + taskname[op] = cmd[ip] + ip = ip + 1 + op = min (SZ_TASKNAME + 1, op + 1) + } + taskname[op] = EOS + + # Determine index of argument list. + while (IS_WHITE (cmd[ip])) + ip = ip + 1 + arglist_offset = ip + + # Get rid of the newline. + for (; cmd[ip] != EOS; ip=ip+1) + if (cmd[ip] == '\n') { + cmd[ip] = EOS + break + } + + return (OK) + } +end + + +# SYS_SCANARGLIST -- Parse the argument list of a task. At the level of the +# iraf main the command syntax is very simple. There are two types of +# arguments, parameter assignments (including switches) and i/o redirection +# directives. All param assignments are of the form "param=value", where +# PARAM must start with a lower case alpha and where VALUE is either quoted or +# is delimited by one of the metacharacters [ \t\n<>\\]. A redirection argument +# is anything which is not a parameter set argument, i.e., any argument which +# does not start with a lower case alpha. + +procedure sys_scanarglist (cmdin, i_args) + +int cmdin # command input stream +char i_args[ARB] # (first part of) argument list + +int fd +char ch +bool skip +pointer sp, fname, args, ip, op +int getlline() + +begin + call smark (sp) + call salloc (args, SZ_CMDBUF, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + call strcpy (i_args, Memc[args], SZ_CMDBUF) + + # Do not skip whitespace for param=value args on the command line. + skip = false + + # Inform FIO that all standard i/o streams are unredirected (overridden + # below if redirected by an argument). + + for (fd=1; fd < FIRST_FD; fd=fd+1) + call fseti (fd, F_REDIR, NO) + + # Process each argument in the argument list. If the command line ends + # with an escaped newline then continuation is assumed. Arguments are + # delimited by whitespace. + + for (ip=args; Memc[ip] != '\n' && Memc[ip] != EOS; ) { + # Advance to the next argument. + while (IS_WHITE (Memc[ip])) + ip = ip + 1 + + # Check for continuation. + ch = Memc[ip] + if (ch == '\\' && (Memc[ip+1] == '\n' || Memc[ip+1] == EOS)) { + if (getlline (cmdin, Memc[args], SZ_CMDBUF) == EOF) { + call sfree (sp) + return + } + ip = args + next + } else if (ch == '\n' || ch == EOS) + break + + # If the argument begins with an alpha, _, or $ (e.g., $nargs) + # then it is a param=value argument, otherwise it must be a redir. + # The form @filename causes param=value pairs to be read from + # the named file. + + if (ch == '@') { + op = fname + for (ip=ip+1; Memc[ip] != EOS; ip=ip+1) + if (IS_WHITE (Memc[ip]) || Memc[ip] == '\n') + break + else if (Memc[ip] == '\\' && Memc[ip+1] == '\n') + break + else { + Memc[op] = Memc[ip] + op = op + 1 + } + Memc[op] = EOS + call sys_getpars (Memc[fname]) + + } else if (IS_ALPHA(ch) || ch == '_' || ch == '$') { + call sys_paramset (Memc, ip, skip) + } else + call sys_redirect (Memc, ip) + } + + call sfree (sp) +end + + +# SYS_GETPARS -- Read a sequence of param=value parameter assignments from +# the named file and enter them into the CLIO cache for the task. + +procedure sys_getpars (fname) + +char fname # pset file + +bool skip +int lineno, fd +pointer sp, lbuf, ip +int open(), getlline() +errchk open, getlline + +begin + call smark (sp) + call salloc (lbuf, SZ_CMDBUF, TY_CHAR) + + fd = open (fname, READ_ONLY, TEXT_FILE) + + # Skip whitespace for param = value args in a par file. + skip = true + + lineno = 0 + while (getlline (fd, Memc[lbuf], SZ_CMDBUF) != EOF) { + lineno = lineno + 1 + for (ip=lbuf; IS_WHITE (Memc[ip]); ip=ip+1) + ; + if (Memc[ip] == '#' || Memc[ip] == '\n') + next + iferr (call sys_paramset (Memc, ip, skip)) { + for (; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + Memc[ip] = EOS + call eprintf ("Bad param assignment, line %d: `%s'\n") + call pargi (lineno) + call pargstr (Memc[lbuf]) + } + } + + call close (fd) + call sfree (sp) +end + + +# SYS_PARAMSET -- Extract the param and value substrings from a param=value +# or switch argument and enter them into the CL parameter cache. (see also +# clio.clcache). + +procedure sys_paramset (args, ip, skip) + +char args[ARB] # argument list +int ip # pointer to first char of argument +bool skip # skip whitespace within "param=value" args + +pointer sp, param, value, op +int stridx() + +begin + call smark (sp) + call salloc (param, SZ_FNAME, TY_CHAR) + call salloc (value, SZ_VALSTR, TY_CHAR) + + # Extract the param field. + op = param + while (IS_ALNUM (args[ip]) || stridx (args[ip], "_.$") > 0) { + Memc[op] = args[ip] + op = op + 1 + ip = ip + 1 + } + Memc[op] = EOS + + # Advance to the switch character or assignment operator. + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '+': + # Boolean switch "yes". + ip = ip + 1 + call strcpy ("yes", Memc[value], SZ_VALSTR) + + case '-': + # Boolean switch "no". + ip = ip + 1 + call strcpy ("no", Memc[value], SZ_VALSTR) + + case '=': + # Extract the value field. This is either a quoted string or a + # string delimited by any of the metacharacters listed below. + + ip = ip + 1 + if (skip) { + while (IS_WHITE (args[ip])) + ip = ip + 1 + } + call sys_gstrarg (args, ip, Memc[value], SZ_VALSTR) + + default: + call error (1, "IRAF Main: command syntax error") + } + + # Enter the param=value pair into the CL parameter cache. + call clc_enter (Memc[param], Memc[value]) + + call sfree (sp) +end + + +# SYS_REDIRECT -- Process a single redirection argument. The syntax of an +# argument to redirect the standard input is +# +# < [fname] +# +# If the filename is omitted it is understood that STDIN has been redirected +# in the CL. The syntax to redirect a standard output stream is +# +# [45678][TB](>|>>)[fname] +# +# where [4567] is the FD number of a standard output stream (STDOUT, STDERR, +# STDGRAPH, STDIMAGE, or STDPLOT), and [TB] indicates if the file is text or +# binary. If the stream is redirected at the CL level the output filename +# will be given as `$', serving only to indicate that the stream is redirected. + +procedure sys_redirect (args, ip) + +char args[ARB] # argument list +int ip # pointer to first char of redir arg + +pointer sp, fname +int fd, mode, type +int ctoi() +define badredir_ 91 +errchk fredir, fseti + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get number of stream (0 if not given). + if (ctoi (args, ip, fd) <= 0) + fd = 0 + + # Get file type (optional). + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case 'T', 't': + type = TEXT_FILE + ip = ip + 1 + case 'B', 'b': + type = BINARY_FILE + ip = ip + 1 + default: + type = 0 + } + + # Check for "<", ">", or ">>". + while (IS_WHITE (args[ip])) + ip = ip + 1 + + switch (args[ip]) { + case '<': + ip = ip + 1 + mode = READ_ONLY + if (fd == 0) + fd = STDIN + else if (fd != STDIN || fd != CLIN) + goto badredir_ + + case '>': + ip = ip + 1 + if (args[ip] == '>') { + ip = ip + 1 + mode = APPEND + } else + mode = NEW_FILE + + if (fd == 0) + fd = STDOUT + else { + switch (fd) { + case CLOUT, STDOUT, STDERR, STDGRAPH, STDIMAGE, STDPLOT: + ; + default: + goto badredir_ + } + } + + default: + # Not a redirection argument. + call error (1, "IRAF Main: command syntax error") + } + + # Set default file type for given stream if no type specified. + if (type == 0) + switch (fd) { + case CLIN, CLOUT, STDIN, STDOUT, STDERR: + type = TEXT_FILE + default: + type = BINARY_FILE + } + + # Extract the filename, if any. If the CL has redirected the output + # and is merely using the redirection syntax to inform us of this, + # the metafilename "$" is given. + + while (IS_WHITE (args[ip])) + ip = ip + 1 + + if (args[ip] == '$') { + Memc[fname] = EOS + ip = ip + 1 + } else + call sys_gstrarg (args, ip, Memc[fname], SZ_FNAME) + + # At this point we have FD, FNAME, MODE and TYPE. If no file is + # named the stream has already been redirected by the parent and + # all we need to is inform FIO that the stream has been redirected. + # Otherwise we redirect the stream in the local process. A locally + # redirected stream will be closed and the normal direction restored + # during FIO cleanup, at program termination or during error + # recovery. + + if (Memc[fname] != EOS) + call fredir (fd, Memc[fname], mode, type) + else + call fseti (fd, F_REDIR, YES) + + call sfree (sp) + return + +badredir_ + call error (2, "IRAF Main: illegal redirection") +end + + +# SYS_GSTRARG -- Extract a string field. This is either a quoted string or a +# string delimited by any of the metacharacters " \t\n<>\\". + +procedure sys_gstrarg (args, ip, outstr, maxch) + +char args[ARB] # input string +int ip # pointer into input string +char outstr[maxch] # receives string field +int maxch + +char delim, ch +int op +int stridx() + +begin + op = 1 + if (args[ip] == '"' || args[ip] == '\'') { + # Quoted value string. + + delim = args[ip] + for (ip=ip+1; args[ip] != delim && args[ip] != EOS; ip=ip+1) { + if (args[ip] == '\n') { + break + } else if (args[ip] == '\\' && args[ip+1] == delim) { + outstr[op] = delim + op = op + 1 + ip = ip + 1 + } else { + outstr[op] = args[ip] + op = op + 1 + } + } + + } else { + # Nonquoted value string. + + for (delim=-1; args[ip] != EOS; ip=ip+1) { + ch = args[ip] + if (ch == '\\' && (args[ip+1] == '\n' || args[ip+1] == EOS)) + break + else if (stridx (ch, " \t\n<>\\") > 0) + break + else { + outstr[op] = ch + op = op + 1 + } + } + } + + outstr[op] = EOS + if (args[ip] == delim) + ip = ip + 1 +end diff --git a/sys/nmemio/malloc.x b/sys/nmemio/malloc.x new file mode 100644 index 00000000..d5886c36 --- /dev/null +++ b/sys/nmemio/malloc.x @@ -0,0 +1,24 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> + +# MALLOC -- Allocate space on the heap. An array of at least NELEMS elements +# of data type DTYPE is allocated, aligned to SZ_MEMALIGN (the biggest type) +# with the global common Mem. + +procedure malloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_MEMALIGN + call zlocva (Memc, fwa_align) + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/nmemio/malloc1.x b/sys/nmemio/malloc1.x new file mode 100644 index 00000000..e5cfd0d3 --- /dev/null +++ b/sys/nmemio/malloc1.x @@ -0,0 +1,130 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + +.help malloc1 +.nf ------------------------------------------------------------------------- +MEMIO -- Internal data structures. + +If "p" is the pointer returned by malloc, the first element of storage is +referenced by the expression "Mem_[p]", where the underscore is replaced +by the appropriate type suffix. A pointer to an object of one data type +is NOT equivalent to a pointer to another data type, even if both pointers +reference the same physical address. + +The actual physical address of the physical buffer area allocated is stored +in the integer cell immediately preceeding the buffer returned to the user. +If this cell is corrupted, the condition will later be detected, and a fatal +error ("memory corrupted") will result. + +For example, for a machine with a 4 byte integer, the first part of the +buffer area might appear as follows (the first few unused cells may or +may not be needed to satisfy the alignment criteria): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 1 + 2 + 3 + 4 byte 1 of saved fwa (address of cell 0) + 5 byte 2 " " " + 6 byte 3 " " " + 7 byte 4 " " " + 8 first cell available to user (maximum alignment) + + +New Scheme allowing for 64-bit architectures(10/15/2009): + + offset allocation + + 0 start of the physical buffer (from zmaloc) + 0-7 alignment space + 8-15 bytes 1-8 of saved fwa (address of cell 0) + 16-23 Bytes 1-8 of upper sentinal location + 24-31 Bytes 1-8 of pointer type + 32-39 Bytes 1-8 of nbytes of storage + 40-47 Bytes 1-8 of lower sentinal value + 48 first cell available to user (maximum alignment) + N+1 Bytes 1-8 of upper sentinal value + + Total storage required is + + [ ((nelems + 1) * sizeof(dtype)) + sz-align + (5 * SZ_INT) ] * SZB_CHAR + + +MALLOC, given the CHAR address of the buffer allocated by the z-routine, +adds space for the saved fwa (an integer), and determines the address of the +next cell which is sufficiently aligned, relative to the Mem common. This +cell marks the start of the user buffer area. The buffer fwa is saved in an +integer location preceding the "first cell". + +MFREE, called with a pointer to the buffer to be returned, fetches the location +of the physical buffer from the save area. If this does not agree with the +buffer pointer, either (1) the buffer pointer is invalid or of the wrong +datatype, or (2), the save area has been overwritten (memory has been +corrupted). If everything checks out, the buffer fwa is passed to a z-routine +to free the physical buffer space. + +TODO: - Add debugging routine to summarize allocated buffer space and + check for buffer overruns (add sentinel at end of buffer). + - Keep track of buffers allocated while a program is running and + return at program termination, like closing open files. +.endhelp --------------------------------------------------------------------- + + + +# MALLOC1 -- Low level procedure which does the actual buffer allocation. + +int procedure malloc1 (output_pointer, nelems, dtype, sz_align, fwa_align) + +pointer output_pointer # buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements +int sz_align # number of chars of alignment required +int fwa_align # address to which buffer is to be aligned + +int fwa, nchars, nuser, status +pointer cp + +int sizeof() +pointer msvfwa(), coerce() + +include "nmemio.com" + +begin + if (dtype == TY_CHAR) + nuser = nelems + 1 # add space for EOS + else + nuser = nelems * sizeof (dtype) + 1 + nchars = nuser + (8 * SZ_INT) + sz_align + + call zmaloc (fwa, (nchars * SZB_CHAR), status) + + if (status == ERR) + return (ERR) + + else { + output_pointer = msvfwa (fwa, dtype, nelems, sz_align, fwa_align) + + if (mclear > 0) { + # Clear the user area only. + cp = coerce (output_pointer, dtype, TY_CHAR) + call aclrc (Memc[cp], (nuser * SZB_CHAR)) + } + + # Update usage stats. + if (mreport > 0) { + nalloc = nalloc + 1 + mem_used = mem_used + (nchars * SZB_CHAR) + if ((nchars * SZB_CHAR) > max_alloc) + max_alloc = (nchars * SZB_CHAR) + } + + # Save the ptr in the GC buffer. + if (mcollect > 0) + call mgc_save (output_pointer, dtype) + + return (OK) + } +end diff --git a/sys/nmemio/merror.x b/sys/nmemio/merror.x new file mode 100644 index 00000000..d69eb6cd --- /dev/null +++ b/sys/nmemio/merror.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> + + +# MERROR -- Provide a convenient trap for a memory error. + +procedure merror (msg) + +char msg[ARB] + +include "nmemio.com" + +begin + if (in_task > 0) + call error (EA_ERROR, msg) +end diff --git a/sys/nmemio/mfini.x b/sys/nmemio/mfini.x new file mode 100644 index 00000000..f3933fa1 --- /dev/null +++ b/sys/nmemio/mfini.x @@ -0,0 +1,57 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> + + +define MDEBUG false + +# MEM_FINI -- Close out the MEMIO use in this task. We perform the memory +# garbage collection and report usage statistics if requested. + +procedure mem_fini (task) + +char task[ARB] # task name + +int sv_report + +include "nmemio.com" + +begin + # Do garbage collection. + call mgc_collect() + + # Turn off reporting so the print statements below don't add + # to the reported values. + sv_report = mreport + mreport = 0 + mdebug = 0 + in_task = 0 + + if (MDEBUG) { + call eprintf ("\nTask '%s':\n") + call pargstr (task) + call eprintf (" mwatch:\t%d\n") ; call pargi (mwatch) + call eprintf (" mclear:\t%d\n") ; call pargi (mclear) + call eprintf (" mcollect:\t%d\n") ; call pargi (mcollect) + call eprintf (" mreport:\t%d\n") ; call pargi (mreport) + } + + # Report memory usage. + if (sv_report > 0) { + call eprintf ("\nTask '%s':\n") + call pargstr (task) + call eprintf (" Memory:\t%9d used (%9d max )\n") + call pargl (mem_used) + call pargi (max_alloc) + call eprintf (" Pointers:\t%9d alloc (%9d free)\n") + call pargi (nalloc) + call pargi (nfree) + call eprintf (" Leaked:\t%9d bytes (%9d ptrs)\n\n") + call pargl (leaked) + call pargl (nleaked) + } + + # Free the GC buffer. + call mgc_close () +end diff --git a/sys/nmemio/mfree.x b/sys/nmemio/mfree.x new file mode 100644 index 00000000..d83149c3 --- /dev/null +++ b/sys/nmemio/mfree.x @@ -0,0 +1,118 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <error.h> + + +# MFREE -- Free a previously allocated buffer. If the buffer has already been +# returned (NULL pointer), ignore the request. Once the buffer has been +# returned, the old pointer value is of not useful (and invalid), so set it +# to NULL. + +procedure mfree (ptr, dtype) + +pointer ptr +int dtype + +pointer bp +int fwa, gc_type, status, lwl +char emsg[SZ_LINE] + +int mgtfwa(), coerce(), mgc_gettype() +errchk mgtfwa + +include "nmemio.com" + +begin + # Check for NULL or already-freed pointers. We only invoke an error + # rather than sys_panic to allow for recovery. + if (ptr < 0) { + call merror ("Attempt to free already freed pointer") + return + } + if (mdebug > 0 && ptr == NULL) { + call merror ("Attempt to free NULL pointer") + return + } + if (mcollect > 0) { + gc_type = mgc_gettype (ptr) + if ((gc_type != NULL && gc_type != dtype) && in_task > 0) { + call merror ("Attempt to free pointer of wrong type") + dtype = gc_type + } + } + + if (ptr != NULL) { + fwa = mgtfwa (ptr, dtype) + + bp = coerce (ptr, dtype, TY_INT) + if (mwatch > 0) { + + # Check the lower sentinal value. Any serious underflow + # would have corrupted the fwa and been detected above in + # mgtfwa(), we really only use this to check for 0/1 indexing + # problems that write before the start od the data. + if (Memi[bp-1] != lsentinal) { + call aclrc (emsg, SZ_LINE) + call sprintf (emsg, SZ_LINE, + "Pointer underflow: addr=0x%x nelem=%d type=%s\n") + call pargi (ptr) + call pargi (Memi[bp-2]) + call ptype (dtype) + if (mreport > 0) + call eprintf (emsg) + call merror (emsg) + } + + # Check the upper sentinal value. Note that the setinal is + # aligned to the INT boundary so depending on the type we + # might still allow a slight overrun. + lwl = Memi[bp-4] + if (Memi[lwl] != usentinal) { + call aclrc (emsg, SZ_LINE) + call sprintf (emsg, SZ_LINE, + "Pointer overflow: addr=0x%x nelem=%d type=%s\n") + call pargi (ptr) + call pargi (Memi[bp-2]) + call ptype (dtype) + if (mreport > 0) + call eprintf (emsg) + call merror (emsg) + } + } + + call zmfree (fwa, status) + if (status == ERR) + call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") + + # Negate the pointer so we can detect another attempt to free it. + if (mcollect > 0 && in_task > 0) + call mgc_update (ptr) + if (mcollect >= 0) + nfree = nfree + 1 + ptr = - ptr + ptr = NULL + } +end + + +# PTYPE -- Convert a pointer type code t its string equivalent. + +procedure ptype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL") + case TY_CHAR: call pargstr ("TY_CHAR") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end diff --git a/sys/nmemio/mgc.x b/sys/nmemio/mgc.x new file mode 100644 index 00000000..8ef2b58c --- /dev/null +++ b/sys/nmemio/mgc.x @@ -0,0 +1,222 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + + +# MGC Interface - Simple memory garbage collector interface. Our strategy +# here is simply to store the pointer and its type (so we can dereference to +# a host pointer). As pointers are allocated they are saved here, and when +# freed the pointer value is made negative to indicate it is invalid and +# that slot is available for later reuse. +# When a task completes, we run through the buffer looking for un-freed +# pointers and manually reclaim the space. This is not especially clever but +# we are only used (presumably by developers) when requested so normal use +# of MEMIO should see no added overhead. +# +# mgc_init () +# mgc_close () +# mgc_save (ptr, dtype) +# mgc_update (ptr) +# index = mgc_getindex (ptr) +# type = mgc_gettype (ptr) +# mgc_collect () + + +define SZ_GC_BUFFER 10240 + +# A zero-indexed structure saving the (ptr,type) pairs. +define GC_PTR Memi[$1+($2 * 2)] +define GC_TYPE Memi[$1+($2 * 2 + 1)] + + +# MGC_INIT -- Initialize the MGC interface. + +procedure mgc_init () + +include "nmemio.com" + +begin + if (mcollect > 0) + call calloc (mgc, SZ_GC_BUFFER, TY_STRUCT) + else + mgc = NULL +end + + +# MGC_CLOSE -- Close the MGC buffer. + +procedure mgc_close () + +include "nmemio.com" + +begin + if (mcollect > 0 && mgc != NULL) { + call mfree (mgc, TY_STRUCT) + mgc = NULL + } +end + + +# MGC_SAVE -- Save a pointer in the GC buffer. + +procedure mgc_save (ptr, dtype) + +pointer ptr #i pointer to save +int dtype #i pointer type + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + for (i=0; i < bmax; i=i+1) { + if (GC_PTR(mgc,i) <= 0) { + # Space is re-used if negative, otherwise first free slot. + GC_PTR(mgc,i) = ptr + GC_TYPE(mgc,i) = dtype + + if (mdebug > 0) { + call eprintf ("save %d: ptr 0x%x\n") + call pargi (i); call pargi (GC_PTR(mgc,i)) + } + return + } + } + + # If we get this far we've exhausted the GC buffer. Print a warning + # if reporting and just ignore it since the chances this would be + # a leaked pointer are rather small. + if (mreport > 0) + call eprintf ("Warning: GC buffer overflow\n") +end + + +# MGC_UPDATE -- Update the status of the pointer in the GC buffer. + +procedure mgc_update (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mgc == NULL || in_task == 0) + return + + if (in_task > 0 && mdebug > 0) { + call eprintf ("update 0x%x collect = %d\n") + call pargi (ptr) + call pargi (mcollect) + } + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (GC_PTR(mgc,i) == ptr) { + if (in_task > 0 && mdebug > 0) { + call eprintf ("update %d: 0x%x %d\n") + call pargi (i); call pargi (GC_PTR(mgc,i)); call pargi (ptr) + } + GC_PTR(mgc,i) = (- ptr) + return + } + if (GC_PTR(mgc,i) == NULL) + return + } +end + + +# MGC_GETINDEX -- Given a pointer, return its GC index. + +int procedure mgc_getindex (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (abs (GC_PTR(mgc,i)) == ptr) + return (i) + if (GC_PTR(mgc,i) == NULL) + return (NULL) + } + + return (NULL) +end + + +# MGC_GETTYPE -- Given a pointer, return its type. + +int procedure mgc_gettype (ptr) + +pointer ptr #i pointer to save + +int i, bmax + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (abs (GC_PTR(mgc,i)) == ptr) + return (GC_TYPE(mgc,i)) + if (GC_PTR(mgc,i) == NULL) + return (NULL) + } + + return (NULL) +end + + +# MGC_COLLECT -- Do the final garbage collection. + +procedure mgc_collect () + +int i, bmax, nchars +pointer bp + +int sizeof () +pointer coerce () + +include "nmemio.com" + +begin + if (mcollect <= 0 || mgc == NULL) + return + mcollect = -1 + + bmax = SZ_GC_BUFFER - 1 + do i = 0, bmax { + if (GC_PTR(mgc,i) > 0) { + if (mdebug > 0) { + call eprintf ("collect %d: recovering ptr 0x%x\n") + call pargi (i); call pargi (GC_PTR(mgc,i)) + } + + bp = coerce (GC_PTR(mgc,i), GC_TYPE(mgc,i), TY_INT) + + nleaked = nleaked + 1 + nchars = Memi[bp - 2] * sizeof (GC_TYPE(mgc,i)) + leaked = leaked + (nchars * SZB_CHAR) + + call mfree (GC_PTR(mgc,i), GC_TYPE(mgc,i)) + + } else if (GC_PTR(mgc,i) == NULL) + return + } +end diff --git a/sys/nmemio/mgdptr.x b/sys/nmemio/mgdptr.x new file mode 100644 index 00000000..81328132 --- /dev/null +++ b/sys/nmemio/mgdptr.x @@ -0,0 +1,33 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# MGDPTR -- Given the fwa of a memory area, compute a pointer to the start +# of the data area which satisfies the desired alignment criteria. Memory +# is allocated in units of chars, and ZLOCVA, ZMALOC, etc., return pointers +# in units of chars. + +pointer procedure mgdptr (fwa, dtype, sz_align, fwa_align) + +int fwa, dtype, sz_align, fwa_align +long bufadr +pointer bufptr +int modulus, loc_Mem +int sizeof() +data loc_Mem /NULL/ + +begin + # Compute the address of the start of the user buffer area, which + # must be aligned with fwa_align (usually Mem) for all data types. + + if (loc_Mem == NULL) + call zlocva (Memc, loc_Mem) + bufadr = fwa + (5 * SZ_INT) + + modulus = mod (bufadr - fwa_align, sz_align) + if (modulus != 0) + bufadr = bufadr + (sz_align - modulus) + + # Compute the buffer pointer for the desired datatype. + bufptr = (bufadr - loc_Mem) / sizeof(dtype) + 1 + + return (bufptr) +end diff --git a/sys/nmemio/mgtfwa.x b/sys/nmemio/mgtfwa.x new file mode 100644 index 00000000..8d3452fd --- /dev/null +++ b/sys/nmemio/mgtfwa.x @@ -0,0 +1,27 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <mach.h> + +# MGTFWA -- Given a user buffer pointer, retrieve physical address of buffer. +# If physical address of buffer does not seem reasonable, memory has probably +# been overwritten, a fatal error. + +int procedure mgtfwa (ptr, dtype) + +pointer ptr, bufptr +int dtype +int locbuf, fwa +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + fwa = Memi[bufptr-5] + call zlocva (Memi[bufptr-5], locbuf) + + if (abs (locbuf - fwa) > (6 * SZ_VMEMALIGN)) + call sys_panic (SYS_MCORRUPTED, "Memory fwa has been corrupted") + + return (fwa) +end diff --git a/sys/nmemio/mgtlwl.x b/sys/nmemio/mgtlwl.x new file mode 100644 index 00000000..3a7d3ac1 --- /dev/null +++ b/sys/nmemio/mgtlwl.x @@ -0,0 +1,18 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <mach.h> + +# MGTLWL -- Given a user buffer pointer, retrieve location of the last word. + +int procedure mgtlwl (ptr, dtype) + +pointer ptr, bufptr +int dtype +int coerce() + +begin + bufptr = coerce (ptr, dtype, TY_INT) + return (Memi[bufptr-4]) +end diff --git a/sys/nmemio/minit.x b/sys/nmemio/minit.x new file mode 100644 index 00000000..06214137 --- /dev/null +++ b/sys/nmemio/minit.x @@ -0,0 +1,127 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> + + +define L_SENTINAL 20030125 +define U_SENTINAL 20040922 + + +# MEM_INIT -- Initialize the MEMIO interface for the task. + +procedure mem_init (task) + +char task[ARB] # task name + +int mgtenv() + +include "nmemio.com" + +begin + # Initialize I/O buffers for stdout/stderr. We do this here to + # create the file buffers without counting these in the memory + # usage stats. +# call fmkbfs (STDOUT) +# call fmkbfs (STDERR) + + # Allocate the garbage collection buffer. + mcollect = mgtenv ("MEMIO_COLLECT") + call mgc_init() + + # Initialize the sentinal values. + lsentinal = L_SENTINAL + usentinal = U_SENTINAL + + mwatch = mgtenv ("MEMIO_WATCH") + mreport = mgtenv ("MEMIO_REPORT") + mclear = mgtenv ("MEMIO_CLEAR") + mdebug = mgtenv ("MEMIO_DEBUG") + + max_alloc = 0 + mem_used = 0 + leaked = 0 + nleaked = 0 + nalloc = 0 + nfree = 0 + + in_task = 1 +end + + +# MGTENV -- Get an environment variable for MEMIO control. + +int procedure mgtenv (varname) + +char varname[ARB] # env variable to find + +int ival, ip, status, junk +char key[SZ_LINE], value[SZ_LINE] + +int ctoi() + +begin + ip = 1 # init + ival = 0 + call aclrc (key, SZ_LINE) + call aclrc (value, SZ_LINE) + + call strpak (varname, key, SZ_LINE) + call zgtenv (key, value, SZ_LINE, status) + call strupk (value, value, SZ_LINE) + + if (status == 0) # variable defined w/out value + ival = 1 + else if (status > 0) # get environment variable value + junk = ctoi (value, ip, ival) + + return (ival) +end + + +# MEM_PTYPE -- Print a pointer type. Used in error messages. + +procedure mem_ptype (dtype) + +int dtype + +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL") + case TY_CHAR: call pargstr ("TY_CHAR") + case TY_SHORT: call pargstr ("TY_SHORT") + case TY_INT: call pargstr ("TY_INT") + case TY_LONG: call pargstr ("TY_LONG") + case TY_REAL: call pargstr ("TY_REAL") + case TY_DOUBLE: call pargstr ("TY_DOUBLE") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT") + case TY_POINTER: call pargstr ("TY_POINTER") + default: call pargstr ("unknown") + } +end + + +# MIO_INIT -- Initialize the MEMIO interface for the task. + +procedure mio_init () + +include "nmemio.com" + +begin + mgc = NULL + mcollect = 0 + mwatch = 0 + mreport = 0 + mclear = 0 + mdebug = 0 + + max_alloc = 0 + mem_used = 0 + leaked = 0 + nleaked = 0 + nalloc = 0 + nfree = 0 + + in_task = 0 +end diff --git a/sys/nmemio/mkpkg b/sys/nmemio/mkpkg new file mode 100644 index 00000000..94cfaed9 --- /dev/null +++ b/sys/nmemio/mkpkg @@ -0,0 +1,31 @@ +# Memory i/o (MEMIO) portion of the system library. + +$checkout libsys.a lib$ +$update libsys.a +$checkin libsys.a lib$ +$exit + +libsys.a: + #$set XFLAGS = "$(XFLAGS) -g" + + begmem.x <mach.h> + calloc.x + coerce.x <szdtype.inc> + kmalloc.x <config.h> + krealloc.x <config.h> <mach.h> + malloc1.x <mach.h> nmemio.com + malloc.x <config.h> + merror.x <error.h> nmemio.com + mfini.x <config.h> nmemio.com + mfree.x <error.h> nmemio.com + mgc.x <mach.h> nmemio.com + mgdptr.x + mgtfwa.x <config.h> <mach.h> + mgtlwl.x <config.h> <mach.h> + minit.x <config.h> nmemio.com + msvfwa.x <mach.h> nmemio.com + realloc.x + salloc.x <config.h> <szdtype.inc> + sizeof.x <szdtype.inc> + vmalloc.x <config.h> <mach.h> + ; diff --git a/sys/nmemio/msvfwa.x b/sys/nmemio/msvfwa.x new file mode 100644 index 00000000..cd3313c5 --- /dev/null +++ b/sys/nmemio/msvfwa.x @@ -0,0 +1,55 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> + + +# MSVFWA -- Determine the buffer address which satisfies the maximum alignment +# criteria, save the buffer fwa in the integer cell immediately preceding +# this, and return a pointer to the user area of the buffer. + +pointer procedure msvfwa (fwa, dtype, nelem, sz_align, fwa_align) + +int fwa, dtype, nelem, sz_align, fwa_align, nbits +pointer bufptr, lwl, offset + +pointer mgdptr() +int coerce(), sizeof() + +include "nmemio.com" + +begin + # Compute the pointer to the data area which satisfies the desired + # alignment criteria. Store the fwa of the actual OS allocated buffer + # in the integer cell preceeding the data area. + + bufptr = mgdptr (fwa, TY_INT, sz_align, fwa_align) + + nbits = sizeof(TY_INT) * 8 * SZB_CHAR + if (nbits == 64) { + if (sizeof (dtype) == sizeof (TY_CHAR)) + offset = (nelem / SZ_INT + 1) + else if (sizeof (dtype) == sizeof (TY_REAL)) + offset = (nelem / SZ_REAL + 1) + else + offset = nelem + + } else if (nbits == 32) { + + if (sizeof(dtype) < sz_align) + offset = (nelem / (SZ_INT / sizeof(dtype))) + 1 + else + offset = (nelem * sizeof (dtype)) / SZB_CHAR + } + + lwl = bufptr + offset + + Memi[bufptr-5] = fwa # first word address + Memi[bufptr-4] = lwl # last word location + Memi[bufptr-3] = dtype # data type + Memi[bufptr-2] = nelem # no. of elements + Memi[bufptr-1] = lsentinal # lower sentinal + Memi[lwl] = usentinal # upper sentinal + + # Return pointer of type dtype to the first cell of the data area. + return (coerce (bufptr, TY_INT, dtype)) +end diff --git a/sys/nmemio/nmemio.com b/sys/nmemio/nmemio.com new file mode 100644 index 00000000..126475c0 --- /dev/null +++ b/sys/nmemio/nmemio.com @@ -0,0 +1,26 @@ + +int mclear # clear newly allocated memory? +int mwatch # check buffer sentinals on FREE? +int mcollect # garbage collect on exit? +int mreport # report memio usage stats? + +int lsentinal # lower sentinal value +int usentinal # upper sentinal value + +long mem_used # total mem usage +long max_alloc # largest allocated pointer size +long leaked # total leaked bytes +int nleaked # number leaked pointers +int nalloc # total number of allocations +int nfree # total number of frees + +int mdebug # debugging memory use in tasks? +int in_task # in task or iraf main? + +pointer mgc # garbage collection buffer + +# Debug common +common /nmemio/ mclear, mwatch, mcollect, mreport, lsentinal, usentinal, + mem_used, max_alloc, nleaked, leaked, nalloc, nfree, + mdebug, in_task, mgc + diff --git a/sys/nmemio/realloc.x b/sys/nmemio/realloc.x new file mode 100644 index 00000000..40229b8f --- /dev/null +++ b/sys/nmemio/realloc.x @@ -0,0 +1,22 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> + +# REALLOC -- Change the size of a previously allocated buffer, moving the +# buffer if necessary. If there is no old buffer (NULL pointer) simply +# allocate a new buffer. + +procedure realloc (ubufp, nelems, dtype) + +pointer ubufp # buffer to be reallocated +int nelems # new size of buffer +int dtype # buffer datatype + +int krealloc() + +begin + if (krealloc (ubufp, nelems, dtype) == ERR) { + ubufp = NULL + call syserr (SYS_MFULL) + } +end diff --git a/sys/nmemio/salloc.x b/sys/nmemio/salloc.x new file mode 100644 index 00000000..34f06217 --- /dev/null +++ b/sys/nmemio/salloc.x @@ -0,0 +1,155 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <config.h> +include <syserr.h> + +# SALLOC.X -- Stack management routines. Stack storage is allocated in +# segments. Space for each segment is dynamically allocated on the heap. +# Each segment contains a pointer to the previous segment to permit +# reclamation of the space (see "Mem.hlp" for additional details). +# This is a low level facility, hence any failure to allocate or deallocate +# stack storage is fatal. + + +# Segment header structure. The header size parameter SZ_STKHDR is defined +# in <config.h> because it is potentially machine dependent. SZ_STKHDR +# must be chosen such that the maximum alignment criteria is maintained. + +define SH_BASE Memi[$1] # char pointer to base of segment +define SH_TOP Memi[$1+1] # char pointer to top of segment + 1 +define SH_OLDSEG Memi[$1+2] # struct pointer to header of prev.seg. + + +# SALLOC -- Allocate space on the stack. + +procedure salloc (output_pointer, nelem, datatype) + +pointer output_pointer # buffer pointer (output) +int nelem # number of elements of storage required +int datatype # datatype of the storage elements + +int nchars, dtype +include <szdtype.inc> +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + dtype = datatype + if (dtype < 1 || dtype > MAX_DTYPE) + call sys_panic (500, "salloc: bad datatype code") + + # Align stack pointer for any data type. Compute amount of + # storage to be allocated. Always add space for at least one + # extra char for the EOS in case a string is stored in the buffer. + + sp = (sp + SZ_MEMALIGN-1) / SZ_MEMALIGN * SZ_MEMALIGN + 1 + if (dtype == TY_CHAR) + nchars = nelem + 1 # add space for EOS + else + nchars = nelem * ty_size[dtype] + 1 + + # Check for stack overflow, add new segment if out of room. + # Since SMARK must be called before SALLOC, cur_seg cannot be + # null, but we check anyhow. + + if (cur_seg == NULL || sp + nchars >= SH_TOP(cur_seg)) + call stk_mkseg (cur_seg, sp, nchars) + + if (dtype == TY_CHAR) + output_pointer = sp + else + output_pointer = (sp-1) / ty_size[dtype] + 1 + + sp = sp + nchars # bump stack pointer +end + + +# SMARK -- Mark the position of the stack pointer, so that stack space +# can be freed by a subsequent call to SFREE. This routine also performs +# initialization of the stack, since it the very first routine called +# during task startup. + +procedure smark (old_sp) + +pointer old_sp # value of the stack pointer (output) +bool first_time +pointer sp, cur_seg +common /salcom/ sp, cur_seg +data first_time /true/ + +begin + if (first_time) { + sp = NULL + cur_seg = NULL + call stk_mkseg (cur_seg, sp, SZ_STACK) + first_time = false + } + + old_sp = sp +end + + +# SFREE -- Free space on the stack. Return whole segments until segment +# containing the old stack pointer is reached. + +procedure sfree (old_sp) + +pointer old_sp # previous value of the stack pointer + +pointer old_seg +pointer sp, cur_seg +common /salcom/ sp, cur_seg + +begin + # The following is needed to avoid recursion when SFREE is called + # by the IRAF main during processing of SYS_MSSTKUNFL. + + if (cur_seg == NULL) + return + + # If the stack underflows (probably because of an invalid pointer) + # it is a fatal error. + + while (old_sp < SH_BASE(cur_seg) || old_sp > SH_TOP(cur_seg)) { + if (SH_OLDSEG(cur_seg) == NULL) + call sys_panic (SYS_MSSTKUNFL, "Salloc underflow") + + old_seg = SH_OLDSEG(cur_seg) # discard segment + call mfree (cur_seg, TY_STRUCT) + cur_seg = old_seg + } + + sp = old_sp # pop stack +end + + +# STK_MKSEG -- Create and add a new stack segment (link at head of the +# segment list). Called during initialization, and upon stack overflow. + +procedure stk_mkseg (cur_seg, sp, segment_size) + +pointer cur_seg # current segment +pointer sp # salloc stack pointer +int segment_size # size of new stack segment + +int nchars, new_seg +pointer coerce() +int kmalloc() + +begin + # Compute size of new segment, allocate the buffer. + nchars = max (SZ_STACK, segment_size) + SZ_STKHDR + if (kmalloc (new_seg, nchars / SZ_STRUCT, TY_STRUCT) == ERR) + call sys_panic (SYS_MFULL, "Out of memory") + + # Output new stack pointer. + sp = coerce (new_seg, TY_STRUCT, TY_CHAR) + SZ_STKHDR + + # Set up the segment descriptor. + SH_BASE(new_seg) = sp + SH_TOP(new_seg) = sp - SZ_STKHDR + nchars + SH_OLDSEG(new_seg) = cur_seg + + # Make new segment the current segment. + cur_seg = new_seg +end diff --git a/sys/nmemio/sizeof.x b/sys/nmemio/sizeof.x new file mode 100644 index 00000000..3b4977fe --- /dev/null +++ b/sys/nmemio/sizeof.x @@ -0,0 +1,12 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# SIZEOF -- Return the size in chars of one of the fundamental datatypes. + +int procedure sizeof (dtype) + +int dtype +include <szdtype.inc> + +begin + return (ty_size[dtype]) +end diff --git a/sys/nmemio/vmalloc.x b/sys/nmemio/vmalloc.x new file mode 100644 index 00000000..25e2de0d --- /dev/null +++ b/sys/nmemio/vmalloc.x @@ -0,0 +1,28 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <syserr.h> +include <config.h> +include <mach.h> + +# VMALLOC -- Like malloc, but force the buffer to be aligned on a virtual +# memory page boundary. This feature can be used, e.g., in 4.XBSD UNIX +# to "bypass" the system buffer cache (to avoid copying file data from the +# system cache into the file buffer). VMALLOC can be made equivalent to MALLOC +# via the parameters in <config.h>, if the local machine which does not have +# virtual memory. + +procedure vmalloc (ubufp, nelems, dtype) + +pointer ubufp # user buffer pointer (output) +int nelems # number of elements of storage required +int dtype # datatype of the storage elements + +int sz_align, fwa_align +int malloc1() + +begin + sz_align = SZ_VMEMALIGN + fwa_align = VMEM_BASE + if (malloc1 (ubufp, nelems, dtype, sz_align, fwa_align) == ERR) + call syserr (SYS_MFULL) +end diff --git a/sys/nmemio/zz.x b/sys/nmemio/zz.x new file mode 100644 index 00000000..c81f1506 --- /dev/null +++ b/sys/nmemio/zz.x @@ -0,0 +1,11 @@ +task hello = t_hello + +procedure t_hello() +pointer t1, t2 +begin + call malloc (t1, SZ_LINE, TY_CHAR) + call mfree (t1, TY_CHAR) + + call malloc (t2, SZ_LINE, TY_INT) + call mfree (t2, TY_INT) +end diff --git a/sys/nmemio/zzdebug.x b/sys/nmemio/zzdebug.x new file mode 100644 index 00000000..556c4fa1 --- /dev/null +++ b/sys/nmemio/zzdebug.x @@ -0,0 +1,86 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Debug MEMIO. + +task stack=t_stack, realloc=t_realloc + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int sza, new_sza, szb, new_szb +int clgeti() + +begin + call malloc (a, SZ_LINE, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + sza = SZ_LINE + call malloc (b, SZ_LINE, TY_CHAR) + call strcpy ("0123456789", Memc[b], ARB) + szb = SZ_LINE + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + repeat { + new_sza = clgeti ("a_bufsize") + if (new_sza == 0) + return + call x_realloc (a, new_sza, TY_CHAR) + new_szb = clgeti ("b_bufsize") + if (new_szb == 0) + return + call x_realloc (b, new_szb, TY_CHAR) + + call eprintf ("a buf %d, size %d --> %d: %s\n") + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("b buf %d, size %d --> %d: %s\n") + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end diff --git a/sys/nmemio/zzfoo.gx b/sys/nmemio/zzfoo.gx new file mode 100644 index 00000000..5de60c5b --- /dev/null +++ b/sys/nmemio/zzfoo.gx @@ -0,0 +1,587 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Test procedures for the NMEMIO interface. +# + +include <mach.h> + + +define MT_HEAP 0 # test heap memory +define MT_STACK 1 # test stack memory + + +task memtest = t_memtest, + stack = t_stack, + realloc = t_realloc + + +# MEMTEST -- Task to test new memio interface. + +procedure t_memtest () + +int model, nerr +pointer str, ptr + +bool clgetb() + +begin + if (clgetb ("stack")) + model = MT_STACK + else + model = MT_HEAP + + # Check we can allocate a large array. + if (model == MT_HEAP) { + call eprintf ("\nBegin large heap malloc tests ....\n\n") + call malloc (str, 256000, TY_STRUCT) + call mfree (str, TY_STRUCT) + call eprintf ("Done\n\n") + + # Print the memory layout. + $for (csiblrdx) + call mt_print (TY_PIXEL) + $endfor + call mt_print (TY_STRUCT) + call mt_print (TY_POINTER) + } + + # Test Mem common assignments + call eprintf ("\nBegin assignment tests ....\n\n"); + call mt_auto_b ("bool ", model) + call mt_auto_c ("char ", model) + call mt_auto_s ("short ", model) + call mt_auto_i ("int ", model) + call mt_auto_l ("long ", model) + call mt_auto_r ("real ", model) + call mt_auto_d ("double ", model) + call mt_auto_x ("complex", model) + call eprintf ("\nEnd assignment tests ....\n\n"); + + + # Test string memory + call eprintf ("Begin Memc test\t\t"); + call calloc (str, SZ_LINE, TY_CHAR) + call aclrc (Memc[str], SZ_LINE) + call strcpy ("test string", Memc[str], SZ_LINE) + call eprintf ("str = '%s' ch[2] = '%c' (should be 's')\n") + call pargstr (Memc[str]) + call pargc (Memc[str+2]) + call mfree (str, TY_CHAR) + + + # Test the struct memory + call eprintf ("\n\n") + call eprintf ("Begin struct test\n") + call mt_struct (model) + call eprintf ("Done\n") + + + # Test memory overflow and then underflow detection. + call eprintf ("\n\n") + call eprintf ("Testing overflow:\t") + nerr = 0 + $for (csiblrdx) + iferr ( call mt_overflow (TY_PIXEL) ) + nerr = nerr + 1; + $endfor + iferr ( call mt_overflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_overflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + call eprintf ("Testing underflow:\t") + nerr = 0 + $for (csiblrdx) + iferr ( call mt_underflow (TY_PIXEL) ) + nerr = nerr + 1; + $endfor + iferr ( call mt_underflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_underflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + # Note this test will leak 1024 bytes because of the error recovery. + call eprintf ("Testing invalid free:\t") + call calloc (ptr, 256, TY_REAL) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing double free:\t") + call calloc (ptr, 256, TY_INT) + call mfree (ptr, TY_INT) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing NULL free:\t") + iferr ( call mfree (NULL, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing recovered free:\n") + call calloc (str, SZ_LINE, TY_CHAR) + call eprintf ("Done\n") + + call eprintf ("\n\nEnd of NMEMIO tests\n") +end + + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack () + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int i, sza, new_sza, szb, new_szb + +begin + sza = SZ_FNAME + szb = SZ_LINE + + call malloc (a, sza, TY_CHAR) + call malloc (b, szb, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + call strcpy ("0123456789", Memc[b], ARB) + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + for (i=1; i <= 10; i=i+1) { + if (i < 5) { + new_sza = sza + 512 ; new_szb = szb + 256 + } else { + new_sza = sza + 256 ; new_szb = szb + 512 + } + call realloc (a, new_sza, TY_CHAR) + call realloc (b, new_szb, TY_CHAR) + + call eprintf ("%2d: a buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("%2d: b buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end + + + +define SZ_TEST 640 +define F_I1 Memi[$1] +define F_I2 Memi[$1+1] +define F_L1 Meml[$1+2] +define F_L2 Meml[$1+3] +define F_R1 Memr[$1+4] +define F_R2 Memr[$1+5] +define F_D1 Memd[P2D($1+8)] +define F_D2 Memd[P2D($1+10)] +define F_I3 Memi[$1+12] +define F_I4 Memi[$1+13] +define F_S1 Mems[P2S($1+14)] +define F_S2 Mems[P2S($1+15)] + + +procedure mt_struct (model) + +int model + +pointer sp, str +real x, y, z +double d1, d2, d3 + +int locva() + +begin + if (model == MT_HEAP) { + call malloc (str, SZ_TEST, TY_STRUCT) + } else { + call smark (sp) + call salloc (str, SZ_TEST, TY_STRUCT) + } + + + F_I1(str) = 1 + F_I2(str) = 2 + F_L1(str) = 3 + F_L2(str) = 4 + F_R1(str) = 5.0 + F_R2(str) = 6.0 + F_D1(str) = 7.0 + F_D2(str) = 8.0 + F_I3(str) = 9 + F_I4(str) = 10 + F_S1(str) = 11 + F_S2(str) = 12 + + x = 2.717 ; d1 = F_R1(str) + y = 2.717 ; d2 = 3.14159d0 ; + z = double(x) ; d3 = double(3.14159) + + call eprintf ("\nd1=%.6g d2=%.6g d3=%.6g x=%.6g y=%.6g z=%.6g)\n\n") + call pargd (d1) ; call pargd (d2) ; call pargd (d3) + call pargr (x) ; call pargr (y) ; call pargr (z) + + call eprintf ("Done Setting values ....\n\ntest = %d %d %d\n\n") + call pargi (str) + call pargi (locva(str)) + call pargi (locva(F_I1(str))) + + # call mdump (str, 64) + + call eprintf ("I1 = %4d I2 = %4d \t%d %d\n") + call pargi (F_I1(str)) ; call pargi (F_I2(str)) + call pargi (locva(F_I1(str))) ; call pargi (locva(F_I2(str))) + + call eprintf ("L1 = %4d L2 = %4d \t%d %d\n") + call pargl (F_L1(str)) ; call pargl (F_L2(str)) + call pargi (locva(F_L1(str))) ; call pargi (locva(F_L2(str))) + + call eprintf ("R1 = %4.1f R2 = %4.1f \t%d %d\n") + call pargr (F_R1(str)) ; call pargr (F_R2(str)) + call pargi (locva(F_R1(str))) ; call pargi (locva(F_R2(str))) + + call eprintf ("D1 = %4.1f D2 = %4.1f \t%d %d\n") + call pargd (F_D1(str)) ; call pargd (F_D2(str)) + call pargi (locva(F_D1(str))) ; call pargi (locva(F_D2(str))) + + call eprintf ("I3 = %4d I4 = %4d \t%d %d\n") + call pargi (F_I3(str)) ; call pargi (F_I4(str)) + call pargi (locva(F_I3(str))) ; call pargi (locva(F_I4(str))) + + call eprintf ("S1 = %4d S2 = %4d \t%d %d\n") + call pargs (F_S1(str)) ; call pargs (F_S2(str)) + call pargi (locva(F_S1(str))) ; call pargi (locva(F_S2(str))) + + + if (model == MT_HEAP) + call mfree (str, TY_STRUCT) + else + call sfree (sp) +end + + +define NVALS 3 + +procedure mt_print (dtype) + +int dtype + +int i, locva(), coerce() +real x +double xx +pointer p, bp, lwl + +begin + call calloc (p, NVALS, dtype) + bp = coerce (p, dtype, TY_INT) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + # Print the ptr header. + call eprintf ("\n") + call eprintf (" p = 0x%-15x %-16d\t%d\n") + call pargi (p) ; call pargi (p) ; call pargi (locva(Memi[bp])) + call eprintf (" fwa = 0x%-15x %-16d\t%d\n") + call pargi (bp-5) ; call pargi (Memi[bp-5]) + call pargi (locva (Memi[bp-5])) + call eprintf (" lwl = 0x%-15x %-16d\t%d\n") + call pargi (bp-4) ; call pargi (Memi[bp-4]) + call pargi (locva (Memi[bp-4])) + call eprintf (" dtype = 0x%-15x %-16d\t%d\n") + call pargi (bp-3) ; call mptype (dtype) + call pargi (locva (Memi[bp-3])) + call eprintf (" nelem = 0x%-15x %-16d\t%d\n") + call pargi (bp-2) ; call pargi (Memi[bp-2]) + call pargi (locva (Memi[bp-2])) + call eprintf ("L sentinal = 0x%-15x %-16d\t%d\n") + call pargi (bp-1) ; call pargi (Memi[bp-1]) + call pargi (locva (Memi[bp-1])) + + + # Print the values. + call eprintf (" data = ") + for (i=0; i < NVALS; i=i+1) { + switch (dtype) { + case TY_BOOL: + call eprintf (" %3b\t\t\t\t\t%-15d") + call pargb (Memb[p+i]) + call pargi (locva(Memb[p+i])) + case TY_CHAR: + call eprintf (" %3c\t\t\t\t\t%-15d") + call pargc (Memc[p+i]) + call pargi (locva(Memc[p+i])) + case TY_SHORT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargs (Mems[p+i]) + call pargi (locva(Mems[p+i])) + case TY_INT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_LONG: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargl (Meml[p+i]) + call pargi (locva(Meml[p+i])) + case TY_REAL: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargr (Memr[p+i]) + call pargi (locva(Memr[p+i])) + case TY_DOUBLE: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargd (Memd[p+i]) + call pargi (locva(Memd[p+i])) + case TY_COMPLEX: + call eprintf (" %3x\t\t\t\t\t%-15d") + call pargx (Memx[p+i]) + call pargi (locva(Memx[p+i])) + case TY_STRUCT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_POINTER: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + } + call eprintf ("\n") + if (i < (NVALS-1)) + call eprintf ("\t\t") + } + + lwl = Memi[bp-4] + call eprintf ("U sentinal = 0x%-15x %-15d\t\t%d\n\n") + call pargi (lwl) ; call pargi (Memi[lwl]) + call pargi (locva (Memi[lwl])) + + call mfree (p, dtype) +end + + +procedure mt_overflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS + 4; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + call mfree (p, dtype) +end + + +procedure mt_underflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE ; Memb[p-1] = FALSE + case TY_CHAR: Memc[p+i] = 'a' + i ; Memc[p-1] = '0' + case TY_SHORT: Mems[p+i] = i ; Mems[p-1] = 999 + case TY_INT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_LONG: Meml[p+i] = i ; Meml[p-1] = 999 + case TY_REAL: Memr[p+i] = x ; Memr[p-1] = 999 + case TY_DOUBLE: Memd[p+i] = xx ; Memd[p-1] = 999 + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) ; Memx[p-1] = 999 + case TY_STRUCT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_POINTER: Memi[p+i] = i ; Memi[p-1] = 999 + } + } + + call mfree (p, dtype) +end + + +procedure mptype (dtype) +int dtype +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL ") + case TY_CHAR: call pargstr ("TY_CHAR ") + case TY_SHORT: call pargstr ("TY_SHORT ") + case TY_INT: call pargstr ("TY_INT ") + case TY_LONG: call pargstr ("TY_LONG ") + case TY_REAL: call pargstr ("TY_REAL ") + case TY_DOUBLE: call pargstr ("TY_DOUBLE ") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT ") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end + + + +# Generic Mem_ test assignment. + +define NAVALS 4 + +$for (bcsilrdx) + +procedure mt_auto_$t (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_PIXEL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_PIXEL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + $if (datatype == b) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = TRUE + call eprintf ("[ %b %b %b %b ]\n") + $endif + $if (datatype == c) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = 'a' + i + call eprintf ("[ %-3c %-3c %-3c %-3c ]\n") + $endif + $if (datatype == x) + for (i=0; i < NAVALS; i=i+1) { + x = i + Mem$t[ip+i] = cmplx(x,0.1) + } + call eprintf ("[ %x %x %x %x ]\n") + $endif + $if (datatype == sil) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + $endif + $if (datatype == rd) + for (i=0; i < NAVALS; i=i+1) + Mem$t[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + $endif + for (i=0; i < NAVALS; i=i+1) + call parg$t (Mem$t[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_PIXEL) + else + call sfree (sp) +end + +$endfor diff --git a/sys/nmemio/zzfoo.x b/sys/nmemio/zzfoo.x new file mode 100644 index 00000000..a9e51dcf --- /dev/null +++ b/sys/nmemio/zzfoo.x @@ -0,0 +1,908 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +# Test procedures for the NMEMIO interface. +# + +include <mach.h> + + +define MT_HEAP 0 # test heap memory +define MT_STACK 1 # test stack memory + + +task memtest = t_memtest, + stack = t_stack, + realloc = t_realloc + + +# MEMTEST -- Task to test new memio interface. + +procedure t_memtest () + +int model, nerr +pointer str, ptr + +bool clgetb() + +begin + if (clgetb ("stack")) + model = MT_STACK + else + model = MT_HEAP + + # Check we can allocate a large array. + if (model == MT_HEAP) { + call eprintf ("\nBegin large heap malloc tests ....\n\n") + call malloc (str, 256000, TY_STRUCT) + call mfree (str, TY_STRUCT) + call eprintf ("Done\n\n") + + # Print the memory layout. + + call mt_print (TY_CHAR) + + call mt_print (TY_SHORT) + + call mt_print (TY_INT) + + call mt_print (TY_BOOL) + + call mt_print (TY_LONG) + + call mt_print (TY_REAL) + + call mt_print (TY_DOUBLE) + + call mt_print (TY_COMPLEX) + + call mt_print (TY_STRUCT) + call mt_print (TY_POINTER) + } + + # Test Mem common assignments + call eprintf ("\nBegin assignment tests ....\n\n"); + call mt_auto_b ("bool ", model) + call mt_auto_c ("char ", model) + call mt_auto_s ("short ", model) + call mt_auto_i ("int ", model) + call mt_auto_l ("long ", model) + call mt_auto_r ("real ", model) + call mt_auto_d ("double ", model) + call mt_auto_x ("complex", model) + call eprintf ("\nEnd assignment tests ....\n\n"); + + + # Test string memory + call eprintf ("Begin Memc test\t\t"); + call calloc (str, SZ_LINE, TY_CHAR) + call aclrc (Memc[str], SZ_LINE) + call strcpy ("test string", Memc[str], SZ_LINE) + call eprintf ("str = '%s' ch[2] = '%c' (should be 's')\n") + call pargstr (Memc[str]) + call pargc (Memc[str+2]) + call mfree (str, TY_CHAR) + + + # Test the struct memory + call eprintf ("\n\n") + call eprintf ("Begin struct test\n") + call mt_struct (model) + call eprintf ("Done\n") + + + # Test memory overflow and then underflow detection. + call eprintf ("\n\n") + call eprintf ("Testing overflow:\t") + nerr = 0 + + iferr ( call mt_overflow (TY_CHAR) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_SHORT) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_INT) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_BOOL) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_LONG) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_REAL) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_DOUBLE) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_COMPLEX) ) + nerr = nerr + 1; + + iferr ( call mt_overflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_overflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + call eprintf ("Testing underflow:\t") + nerr = 0 + + iferr ( call mt_underflow (TY_CHAR) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_SHORT) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_INT) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_BOOL) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_LONG) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_REAL) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_DOUBLE) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_COMPLEX) ) + nerr = nerr + 1; + + iferr ( call mt_underflow (TY_STRUCT) ) + nerr = nerr + 1; + iferr ( call mt_underflow (TY_POINTER) ) + nerr = nerr + 1; + call eprintf ("No. errors detected = %d of 10\t\tDone\n") + call pargi (nerr) + + + # Note this test will leak 1024 bytes because of the error recovery. + call eprintf ("Testing invalid free:\t") + call calloc (ptr, 256, TY_REAL) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing double free:\t") + call calloc (ptr, 256, TY_INT) + call mfree (ptr, TY_INT) + iferr ( call mfree (ptr, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing NULL free:\t") + iferr ( call mfree (NULL, TY_INT) ) + call eprintf ("Detected\t\t\t\t") + else + call eprintf ("Undetected\t\t\t\t") + call eprintf ("Done\n") + + call eprintf ("Testing recovered free:\n") + call calloc (str, SZ_LINE, TY_CHAR) + call eprintf ("Done\n") + + call eprintf ("\n\nEnd of NMEMIO tests\n") +end + + + +# Test the SALLOC routine, which allocates storage on the stack. + +procedure t_stack () + +int bufsize +pointer sp, junk +int clglpi() + +begin + call smark (sp) + + while (clglpi ("buffer_size", bufsize) != EOF) { + call salloc (junk, bufsize, TY_CHAR) + call printf ("buffer pointer=%d, size=%d\n") + call pargi (junk) + call pargi (bufsize) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# Test the REALLOC procedure, used to change the size of a buffer. +# Work with two buffers, so that memory can be fragmented, forcing buffers +# to move. + +procedure t_realloc() + +pointer a, b +int i, sza, new_sza, szb, new_szb + +begin + sza = SZ_FNAME + szb = SZ_LINE + + call malloc (a, sza, TY_CHAR) + call malloc (b, szb, TY_CHAR) + call strcpy ("abcdefghijk", Memc[a], ARB) + call strcpy ("0123456789", Memc[b], ARB) + + call eprintf ("a is at %d, size %d: %s\n") + call pargi (a) + call pargi (sza) + call pargstr (Memc[a]) + call eprintf ("b is at %d, size %d: %s\n") + call pargi (b) + call pargi (szb) + call pargstr (Memc[b]) + call eprintf ("-------------------------------\n") + + for (i=1; i <= 10; i=i+1) { + if (i < 5) { + new_sza = sza + 512 ; new_szb = szb + 256 + } else { + new_sza = sza + 256 ; new_szb = szb + 512 + } + call realloc (a, new_sza, TY_CHAR) + call realloc (b, new_szb, TY_CHAR) + + call eprintf ("%2d: a buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (a) + call pargi (sza) + call pargi (new_sza) + call pargstr (Memc[a]) + call eprintf ("%2d: b buf %d, size %d --> %d: %s\n") + call pargi (i) + call pargi (b) + call pargi (szb) + call pargi (new_szb) + call pargstr (Memc[b]) + + sza = new_sza + szb = new_szb + } + + call mfree (a, TY_CHAR) + call mfree (b, TY_CHAR) +end + + + +define SZ_TEST 640 +define F_I1 Memi[$1] +define F_I2 Memi[$1+1] +define F_L1 Meml[$1+2] +define F_L2 Meml[$1+3] +define F_R1 Memr[$1+4] +define F_R2 Memr[$1+5] +define F_D1 Memd[P2D($1+8)] +define F_D2 Memd[P2D($1+10)] +define F_I3 Memi[$1+12] +define F_I4 Memi[$1+13] +define F_S1 Mems[P2S($1+14)] +define F_S2 Mems[P2S($1+15)] + + +procedure mt_struct (model) + +int model + +pointer sp, str +real x, y, z +double d1, d2, d3 + +int locva() + +begin + if (model == MT_HEAP) { + call malloc (str, SZ_TEST, TY_STRUCT) + } else { + call smark (sp) + call salloc (str, SZ_TEST, TY_STRUCT) + } + + + F_I1(str) = 1 + F_I2(str) = 2 + F_L1(str) = 3 + F_L2(str) = 4 + F_R1(str) = 5.0 + F_R2(str) = 6.0 + F_D1(str) = 7.0 + F_D2(str) = 8.0 + F_I3(str) = 9 + F_I4(str) = 10 + F_S1(str) = 11 + F_S2(str) = 12 + + x = 2.717 ; d1 = F_R1(str) + y = 2.717 ; d2 = 3.14159d0 ; + z = double(x) ; d3 = double(3.14159) + + call eprintf ("\nd1=%.6g d2=%.6g d3=%.6g x=%.6g y=%.6g z=%.6g)\n\n") + call pargd (d1) ; call pargd (d2) ; call pargd (d3) + call pargr (x) ; call pargr (y) ; call pargr (z) + + call eprintf ("Done Setting values ....\n\ntest = %d %d %d\n\n") + call pargi (str) + call pargi (locva(str)) + call pargi (locva(F_I1(str))) + + # call mdump (str, 64) + + call eprintf ("I1 = %4d I2 = %4d \t%d %d\n") + call pargi (F_I1(str)) ; call pargi (F_I2(str)) + call pargi (locva(F_I1(str))) ; call pargi (locva(F_I2(str))) + + call eprintf ("L1 = %4d L2 = %4d \t%d %d\n") + call pargl (F_L1(str)) ; call pargl (F_L2(str)) + call pargi (locva(F_L1(str))) ; call pargi (locva(F_L2(str))) + + call eprintf ("R1 = %4.1f R2 = %4.1f \t%d %d\n") + call pargr (F_R1(str)) ; call pargr (F_R2(str)) + call pargi (locva(F_R1(str))) ; call pargi (locva(F_R2(str))) + + call eprintf ("D1 = %4.1f D2 = %4.1f \t%d %d\n") + call pargd (F_D1(str)) ; call pargd (F_D2(str)) + call pargi (locva(F_D1(str))) ; call pargi (locva(F_D2(str))) + + call eprintf ("I3 = %4d I4 = %4d \t%d %d\n") + call pargi (F_I3(str)) ; call pargi (F_I4(str)) + call pargi (locva(F_I3(str))) ; call pargi (locva(F_I4(str))) + + call eprintf ("S1 = %4d S2 = %4d \t%d %d\n") + call pargs (F_S1(str)) ; call pargs (F_S2(str)) + call pargi (locva(F_S1(str))) ; call pargi (locva(F_S2(str))) + + + if (model == MT_HEAP) + call mfree (str, TY_STRUCT) + else + call sfree (sp) +end + + +define NVALS 3 + +procedure mt_print (dtype) + +int dtype + +int i, locva(), coerce() +real x +double xx +pointer p, bp, lwl + +begin + call calloc (p, NVALS, dtype) + bp = coerce (p, dtype, TY_INT) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + # Print the ptr header. + call eprintf ("\n") + call eprintf (" p = 0x%-15x %-16d\t%d\n") + call pargi (p) ; call pargi (p) ; call pargi (locva(Memi[bp])) + call eprintf (" fwa = 0x%-15x %-16d\t%d\n") + call pargi (bp-5) ; call pargi (Memi[bp-5]) + call pargi (locva (Memi[bp-5])) + call eprintf (" lwl = 0x%-15x %-16d\t%d\n") + call pargi (bp-4) ; call pargi (Memi[bp-4]) + call pargi (locva (Memi[bp-4])) + call eprintf (" dtype = 0x%-15x %-16d\t%d\n") + call pargi (bp-3) ; call mptype (dtype) + call pargi (locva (Memi[bp-3])) + call eprintf (" nelem = 0x%-15x %-16d\t%d\n") + call pargi (bp-2) ; call pargi (Memi[bp-2]) + call pargi (locva (Memi[bp-2])) + call eprintf ("L sentinal = 0x%-15x %-16d\t%d\n") + call pargi (bp-1) ; call pargi (Memi[bp-1]) + call pargi (locva (Memi[bp-1])) + + + # Print the values. + call eprintf (" data = ") + for (i=0; i < NVALS; i=i+1) { + switch (dtype) { + case TY_BOOL: + call eprintf (" %3b\t\t\t\t\t%-15d") + call pargb (Memb[p+i]) + call pargi (locva(Memb[p+i])) + case TY_CHAR: + call eprintf (" %3c\t\t\t\t\t%-15d") + call pargc (Memc[p+i]) + call pargi (locva(Memc[p+i])) + case TY_SHORT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargs (Mems[p+i]) + call pargi (locva(Mems[p+i])) + case TY_INT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_LONG: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargl (Meml[p+i]) + call pargi (locva(Meml[p+i])) + case TY_REAL: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargr (Memr[p+i]) + call pargi (locva(Memr[p+i])) + case TY_DOUBLE: + call eprintf (" %3g\t\t\t\t\t%-15d") + call pargd (Memd[p+i]) + call pargi (locva(Memd[p+i])) + case TY_COMPLEX: + call eprintf (" %3x\t\t\t\t\t%-15d") + call pargx (Memx[p+i]) + call pargi (locva(Memx[p+i])) + case TY_STRUCT: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + case TY_POINTER: + call eprintf (" %3d\t\t\t\t\t%-15d") + call pargi (Memi[p+i]) + call pargi (locva(Memi[p+i])) + } + call eprintf ("\n") + if (i < (NVALS-1)) + call eprintf ("\t\t") + } + + lwl = Memi[bp-4] + call eprintf ("U sentinal = 0x%-15x %-15d\t\t%d\n\n") + call pargi (lwl) ; call pargi (Memi[lwl]) + call pargi (locva (Memi[lwl])) + + call mfree (p, dtype) +end + + +procedure mt_overflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS + 4; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE + case TY_CHAR: Memc[p+i] = 'a' + i + case TY_SHORT: Mems[p+i] = i + case TY_INT: Memi[p+i] = i + case TY_LONG: Meml[p+i] = i + case TY_REAL: Memr[p+i] = x + case TY_DOUBLE: Memd[p+i] = xx + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) + case TY_STRUCT: Memi[p+i] = i + case TY_POINTER: Memi[p+i] = i + } + } + + call mfree (p, dtype) +end + + +procedure mt_underflow (dtype) + +int dtype + +int i +real x +double xx +pointer p + +begin + call calloc (p, NVALS, dtype) + + # Set the values. + for (i=0; i < NVALS; i=i+1) { + x = i ; xx = i + switch (dtype) { + case TY_BOOL: Memb[p+i] = TRUE ; Memb[p-1] = FALSE + case TY_CHAR: Memc[p+i] = 'a' + i ; Memc[p-1] = '0' + case TY_SHORT: Mems[p+i] = i ; Mems[p-1] = 999 + case TY_INT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_LONG: Meml[p+i] = i ; Meml[p-1] = 999 + case TY_REAL: Memr[p+i] = x ; Memr[p-1] = 999 + case TY_DOUBLE: Memd[p+i] = xx ; Memd[p-1] = 999 + case TY_COMPLEX: Memx[p+i] = cmplx(x,-x) ; Memx[p-1] = 999 + case TY_STRUCT: Memi[p+i] = i ; Memi[p-1] = 999 + case TY_POINTER: Memi[p+i] = i ; Memi[p-1] = 999 + } + } + + call mfree (p, dtype) +end + + +procedure mptype (dtype) +int dtype +begin + switch (dtype) { + case TY_BOOL: call pargstr ("TY_BOOL ") + case TY_CHAR: call pargstr ("TY_CHAR ") + case TY_SHORT: call pargstr ("TY_SHORT ") + case TY_INT: call pargstr ("TY_INT ") + case TY_LONG: call pargstr ("TY_LONG ") + case TY_REAL: call pargstr ("TY_REAL ") + case TY_DOUBLE: call pargstr ("TY_DOUBLE ") + case TY_COMPLEX: call pargstr ("TY_COMPLEX") + case TY_STRUCT: call pargstr ("TY_STRUCT ") + case TY_POINTER: call pargstr ("TY_POINTER") + } +end + + + +# Generic Mem_ test assignment. + +define NAVALS 4 + + + +procedure mt_auto_b (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_BOOL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_BOOL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memb[ip+i] = TRUE + call eprintf ("[ %b %b %b %b ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargb (Memb[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_BOOL) + else + call sfree (sp) +end + + + +procedure mt_auto_c (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_CHAR) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_CHAR) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memc[ip+i] = 'a' + i + call eprintf ("[ %-3c %-3c %-3c %-3c ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargc (Memc[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_CHAR) + else + call sfree (sp) +end + + + +procedure mt_auto_s (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_SHORT) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_SHORT) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Mems[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargs (Mems[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_SHORT) + else + call sfree (sp) +end + + + +procedure mt_auto_i (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_INT) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_INT) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memi[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargi (Memi[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_INT) + else + call sfree (sp) +end + + + +procedure mt_auto_l (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_LONG) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_LONG) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Meml[ip+i] = i + call eprintf ("[ %-3d %-3d %-3d %-3d ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargl (Meml[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_LONG) + else + call sfree (sp) +end + + + +procedure mt_auto_r (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_REAL) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_REAL) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memr[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargr (Memr[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_REAL) + else + call sfree (sp) +end + + + +procedure mt_auto_d (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_DOUBLE) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_DOUBLE) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) + Memd[ip+i] = i + call eprintf ("[ %-3g %-3g %-3g %-3g ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargd (Memd[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_DOUBLE) + else + call sfree (sp) +end + + + +procedure mt_auto_x (ty, model) + +char ty[ARB] +int model + +int i +real x +pointer sp, ip + +begin + call eprintf (" %s\t ") + call pargstr (ty) + + if (model == MT_HEAP) { + call malloc (ip, NAVALS, TY_COMPLEX) + } else { + call smark (sp) + call salloc (ip, NAVALS, TY_COMPLEX) + } + + + call eprintf ("0x%-15x %-15d\t ") + call pargi(ip) + call pargi(ip) + + x = 0.0 + for (i=0; i < NAVALS; i=i+1) { + x = i + Memx[ip+i] = cmplx(x,0.1) + } + call eprintf ("[ %x %x %x %x ]\n") + for (i=0; i < NAVALS; i=i+1) + call pargx (Memx[ip+i]) + + + if (model == MT_HEAP) + call mfree (ip, TY_COMPLEX) + else + call sfree (sp) +end + + |