#-h- inilsp.lsp 5542 ascii 15-Jan-84 14:27:50 (defprop zerop (lambda(i) (cond ((eq i 0.0) t) (t nil))) value) (defprop onep (lambda(i) (cond ((eq i 1.0) t) (t nil))) value) (defprop replace (lambda (x y e) (prog nil (cond ((atom e) (return nil))) (cond ((atom (car e)) (cond ((eq x (car e)) (rplaca e y)) )) (t (replace x y (car e))) ) (cond ((atom (cdr e)) (cond ((eq x (cdr e)) (rplacd e y)) )) (t (replace x y (cdr e))) ) (return e) )) value) (defprop copy (lambda(l) (cond ((atom l) l) (t (cons (copy (car l))(copy (cdr l)))) ) ) value) (define ( (map (lambda (fn x) (while (null(atom x)) (fn x) (setq x (cdr x)) ))) (maplist (lambda (fn x) (cond ((null x) nil) (t (cons (fn x) (maplist fn (cdr x)))) ))) (mapcar (lambda (fn x) (cond ((null x) nil) (t (cons (fn (car x)) (mapcar fn (cdr x)))) ))) (mapcan (lambda (fn map-$$$x) (cond ((null map-$$$x) nil) (t (append (fn (car map-$$$x)) (mapcan fn (cdr map-$$$x)))) ))) (mapc (lambda (fn x) (while (null(atom x)) (fn (car x)) (setq x (cdr x)) ))) )) ;(defun mapcar (fn l) ; (cond ((null l) nil) ; (t (cons (apply fn (list (car l))) (mapcar fn (cdr l)))) ; ) ;) (defun append append-$$$x (progn (setq append-$$$x (eval (cons 'list append-$$$x))) (prog (l) (setq l (car append-$$$x)) (setq append-$$$x (cdr append-$$$x)) (while append-$$$x (setq l (append2 l (car append-$$$x))) (setq append-$$$x (cdr append-$$$x)) ) (return l)) )) (defun append2 (x y) (cond ((null x) y) (t (cons (car x) (append2 (cdr x) y))) )) (defun assoc (e l) (cond ((null l) nil) ((equal e (caar l)) (car l)) (t (assoc e (cdr l))) )) (defun reverse (l) ((label reverse1 (lambda (l m) (cond ((atom l) m) (t (reverse1 (cdr l) (cons (car l) m))) )) ) l nil) ) (defun length (l) (prog (len) (setq len 0) (while l (setq len (add1 len)) (setq l (cdr l))) (return len) )) (defun subst (x y s) (cond ((equal y s) x) ((atom s) s) (t (cons (subst x y (car s)) (subst x y (cdr s)) )) )) (defun last ($$$l) (cond ((cdr $$$l) (while (cdr $$$l) (setq $$$l (cdr $$$l)) $$$l)) (t $$$l) )) ; The following functions were added by dpm 23-Dec-82 and later. (defun apply (f l) (cond ((eq (car f) 'lambda) (cond ((atom (cadr f)) (eval (cons f l))) (t (eval (cons f (q-list l)))))) (t (cond ((eq (car f) 'fsubr) (eval (cons f l))) (t (eval (cons f (q-list l))))) ))) (defun q-list (l) (mapcar '(lambda (x) (list 'quote x)) l)) (defun randomi (n) (fix (times (random nil) n)) ) ; ; CAR/CDR combinations up through c????r ; (defun caaar (l) (car (caar l))) (defun caadr (l) (car (cadr l))) (defun cadar (l) (car (cdar l))) (defun caddr (l) (car (cddr l))) (defun cdaar (l) (cdr (caar l))) (defun cdadr (l) (cdr (cadr l))) (defun cddar (l) (cdr (cdar l))) (defun cdddr (l) (cdr (cddr l))) (defun caaaar (l) (car (caaar l))) (defun caaadr (l) (car (caadr l))) (defun caadar (l) (car (cadar l))) (defun caaddr (l) (car (caddr l))) (defun cadaar (l) (car (cdaar l))) (defun cadadr (l) (car (cdadr l))) (defun cadddr (l) (car (cdddr l))) (defun cdaaar (l) (cdr (caaar l))) (defun cdaadr (l) (cdr (caadr l))) (defun cdadar (l) (cdr (cadar l))) (defun cdaddr (l) (cdr (caddr l))) (defun cddaar (l) (cdr (cdaar l))) (defun cddadr (l) (cdr (cdadr l))) (defun cddddr (l) (cdr (cdddr l))) ; ; More CAR/CDR shorthand ; (defun first (l) (car l)) (defun second (l) (cadr l)) (defun third (l) (caddr l)) (defun fourth (l) (cadddr l)) (defun fifth (l) (car (cddddr l))) (defun sixth (l) (car (cdr (cddddr l)))) ; ; Arithmetic Shorthand ; (setq * times) (setq + plus) (setq / quotient) (setq - difference) (setq > greaterp) (setq < lessp) (setq == equal) (defun <= (x y) (or (< x y) (== x y))) (defun >= (x y) (or (> x y) (== x y))) (defun nthcdr (n l) (cond ((zerop n) l) ((onep n) (cond ((null l) nil) (t (cdr l)))) (t (nthcdr (sub1 n) (cdr l))) ) ) (defun nth (n l) (prog (x) (setq x (nthcdr n l)) (return (cond ((null x) nil) (t (car x))) ) ) ) (define ( (progn (macro x (list (cons 'lambda (cons () (cdr x)))))))) ; ; My favorite shell commands... ; (defun spawn_cmd (cmd args) (spawn (cond ((null args) cmd) (t (concat cmd " " args))))) (defun cat (f) (spawn_cmd "cat" f)) (defun d (s) (spawn "d" s)) (defun date (s) (spawn "date" s)) (defun dd () (spawn "d -hv")) (defun del (s) (spawn_cmd "sh -c delete" s)) (defun df () (spawn_cmd "sh -c" "df")) (defun dir (f) (spawn_cmd "sh -c dir" f)) (defun dr () (spawn "sh -c dir /size=all /prot /date=mod")) (defun e (f) (spawn_cmd "e" f)) (defun ls (s) (spawn "ls" s)) (defun ps () (spawn "ps -hx")) (defun rm (f) (spawn_cmd "rm" f)) (defun ss () (spawn "sh -c show system")) (defun who (s) (spawn_cmd "who" s)) (defun ww () (spawn "who -hv")) #-t- inilsp.lsp 5542 ascii 15-Jan-84 14:27:50 #-h- lisp.fmt 1512 ascii 15-Jan-84 14:27:51 .de hd .pl 60 .bp .in 4 .rm 72 .he '$1 $2'$3 $4 $5 $6 $7 $8'$1 $2' .fo ''-#-'' .fi .in 8 .ti -4 NAME .br $1 - .en .de sy .sp 1 .ti -4 SYNOPSIS .br .nf .en .de ds .fi .sp .ti -4 DESCRIPTION .br .en .de fu .fi .sp 1 .ti -4 FUNCTION .br .en .de di .fi .sp .ti -4 DIAGNOSTICS .br .en .de re .fi .sp .ti -4 RETURNS .br .en .de fl .fi .sp .ti -4 FILES .br .en .de ex .fi .sp .ti -4 EXAMPLES .nf .br .en .de im .fi .sp .ti -4 IMPLEMENTATION .br .en .de sa .fi .sp .ti -4 SEE ALSO .br .en .de am .fi .sp .ti -4 ARGUMENTS MODIFIED .br .en .de ca .fi .sp .ti -4 CALLS .br .en .de bu .fi .sp .ti -4 BUGS/DEFICIENCIES .br .en .de au .fi .sp .ti -4 AUTHORS .br .en .hd Lisp (1) 30-Dec-82 Lisp interpreter .sy lisp [-b] [-q] [-v] [file] ... .ds Lisp is an interpreter for the Language LISP. For a complete description of the language see the Reference Manual. .sp When Lisp is invoked "normally" (i.e. without any option flags or file names), the file "inilsp.lsp" is automatically loaded, using the standard Software Tools search path. .sp If file names are present on the command line, they are loaded into Lisp after "inilsp.lsp" in the order they appear in the command. Lisp accepts the following options: .sp .in +5 .ti -3 -b Invoke a BARE lisp, without loading "inilsp.lsp" .sp .ti -3 -q Quiet operation. Don't print "Loading ..." messages. .sp .ti -3 -v Verbose operation. Print what is EVALed when loading. .in -5 .sa The LISP Refernce Manual. .au Charlie Dolan and Dave Martin (Hughes Aircraft) .bu Of course... #-t- lisp.fmt 1512 ascii 15-Jan-84 14:27:51 #-h- lisp.inc 5076 ascii 15-Jan-84 14:27:51 #-h- cflag 256 ascii 15-Jan-84 14:25:52 ### CFlag Common block for holding option flag status common /cflag/ bare, quiet, verbos integer bare # YES => don't load LISP_INIT integer quiet # YES => Don't print "Loading ..." messages. integer verbos # YES => Print results of EVAL when LOADing. #-t- cflag 256 ascii 15-Jan-84 14:25:52 #-h- cgcs 101 ascii 15-Jan-84 14:25:52 ### CGCS Common block used by the string-space collection routines. common /cgcs/ base integer base #-t- cgcs 101 ascii 15-Jan-84 14:25:52 #-h- lspcm 4183 ascii 15-Jan-84 14:25:52 % implicit none # This array overlays all the internal atoms for ROLLOUT LISPVAL symtbl(ROLLOUT_BLOCK_SIZE) equivalence (symtbl,QUNBOUND) # I/O devices common /logun/ inplvl, inpstk(MAX_INPUT_LEVELS), output, errlog, lu(5), defin, defout integer inplvl filedes inpstk, output, errlog, lu, defin, defout # Character buffer used by the i/o routines for buffered i/o common /rdcom/ icbuf(MAXLINE), icptr, rerflg, rprmt, lsym, rsym integer icptr character icbuf LISPVAL rerflg, lsym, rsym character rprmt(6) # A vector containing the buckets into which all symbols are hashed common /oblit/ oblist(OBLIST_LENGTH), oblen integer oblen LISPVAL oblist # Variables used in parameter passing common /regcm/ areg, breg, creg, dreg, ereg integer areg, breg, creg, dreg, ereg real ab, bc, cd, de equivalence (areg, ab), (breg, bc), (creg, cd), (dreg, de) # Variables for symbol definitions used by the interpreter common /symcm/ QUNBOUND, QVALUE, QPNAME, qread, QPRINT, clsf, qcar, qcdr, qcons, QRPLACA, QRPLACD, QSYMBOLP, QSTRINGP, qatom, QDEFPROP, QPUTPROP, qget, qeq, QEQUAL, quote, qsubr, qnull, qset, qsetq, iqp143, qeval, qplus, QMINUS, QTIMES, QDIVIDE, QFSUBR, qcond, QBINDING, QLAMBDA, qexpr, qload, qtrue, QNUMBERP, QTOPLEVEL, qprog, QRETURN, qminsp, qwhile, qdo, qterpr, qdotpt, QGREATRP, qlessp, qdot, qblnk, qlpar, qrpar, qlist, qarray, QACCESS, qstore, qgensm, qfor, qbrkp, QRDACC, QWRACC, QAPACC, qshwst, qfexpr, readfn, printf, evalf, dotptf, equalf, qlabel, qgo, qfnarg, qgc, qlsubr, QERROR, QICHANNEL, QOCHANNEL, qquote, rheadf, rtailf, dmembf, qmacro, qrmac, qlbrkt, qrbrkt LISPVAL QUNBOUND, QVALUE, QPNAME, qread, QPRINT, clsf, qcar, qcdr, qcons, QRPLACA, QRPLACD, QSYMBOLP, QSTRINGP, qatom, QDEFPROP, QPUTPROP, qget, qeq, QEQUAL, quote, qsubr, qnull, qset, qsetq, iqp143, qeval, qplus, QMINUS, QTIMES, QDIVIDE, QFSUBR, qcond, QBINDING, QLAMBDA, qexpr, qload, qtrue, QNUMBERP, QTOPLEVEL, qprog, QRETURN, qminsp, qwhile, qdo, qterpr, qdotpt, QGREATRP, qlessp, qdot, qblnk, qlpar, qrpar, qlist, qarray, QACCESS, qstore, qgensm, qfor, qbrkp, QRDACC, QWRACC, QAPACC, qshwst, qfexpr, readfn, printf, dotptf, evalf, equalf, qlabel, qgo, qfnarg, qgc, qlsubr, QERROR, QICHANNEL, QOCHANNEL, qquote, rheadf, rtailf, dmembf, qmacro, qrmac, qlbrkt, qrbrkt # Variable for the address of the top-level READ-EVAL-PRINT loop common /topcm/ TOPOFLISP, savedsp integer TOPOFLISP integer savedsp common /prgcm/ rflg, rval, rlabl, prstk(PROG_STACK_SIZE), prptr, gval, glabl, progsp integer rflg # Tells the prog when a return has been executed LISPVAL rval # The value to be returned ADDRESS rlabl integer prptr, prstk LISPVAL gval ADDRESS glabl integer progsp common /brkcm/ ilev(4), level integer ilev # 4-character array for the BREAK prompt integer level # The BREAK level common /cntcm/ cstk(CONTEXT_STACK_SIZE), cptr integer cstk # The context stack array integer cptr # The Top-of-stack pointer for the context stack # Common block for the PRINT routines common /prcom/ prbuf(MAXLINE), pcptr integer pcptr character prbuf # Temporary scratch buffers common /tmpcm/ strbuf(MAX_STRING), t1buf(MAX_STRING) character strbuf integer t1buf # Used in loading segments for interpreted functions common /rntcm/ rtnadr, sgmnts(3, 10), CURRSEG integer rtnadr # Return address after the segment load integer sgmnts # Character array for the segment names integer CURRSEG # Number of the currently loaded segment common /gencm/ symcnt integer symcnt # The next symbol for GENSYM # Some frequently-used functions # LISPVAL car, cdr, cons, RPLACA, RPLACD LISPVAL cons, rplaa, rplad LISPVAL ipopa common /gccom/ cqueue(0:QUEUE_LENGTH), nxtele, press integer cqueue, nxtele, press common /segcm/ parm(5) integer parm common /stkcm/ dstack(DATA_STACK_SIZE), dsp integer dstack, dsp common /emax/ lists(T:DATA_SPACE), lptr, arrays(ARRAY_SPACE), av, strngs(STRING_SPACE), stptr, nodect, ayptr integer lists # List node array integer lptr # List node pointer integer nodect integer arrays # Array for storing LISP arrays integer av integer ayptr integer stptr character strngs #-t- lspcm 4183 ascii 15-Jan-84 14:25:52 #-h- lspem 0 ascii 15-Jan-84 14:25:53 #-t- lspem 0 ascii 15-Jan-84 14:25:53 #-t- lisp.inc 5076 ascii 15-Jan-84 14:27:51 #-h- lisp.r 161312 ascii 15-Jan-84 14:27:56 #-h- defns 5767 ascii 15-Jan-84 13:57:15 define(prompt,ledpmt) # Use fancy prompt routine. define(CHECK_ARGUMENTS,) # Perform argument checking on function entry. # It is not a good idea to turn this off unless # you're prepared to face the consequences. # # These define all the bits in the extra field of a node. # define(ATOM_HEADER,255) # ALL THE ATOM BITS define(MARK_BIT,256) define(TAG_BIT,512) define(FREE_BIT,1024) define(SYMBOL_BIT,1) define(SUBR_BIT,2) define(FLONUM_BIT,4) define(STRING_BIT,8) # # These define the size of the three large arrays. # ifdef( LARGE_ADDRESS_SPACE ) define(DATA_SPACE,60000) define(ARRAY_SPACE,20480) define(STRING_SPACE,60000) elsedef define(DATA_SPACE,30000) define(ARRAY_SPACE,20480) define(STRING_SPACE,15000) enddef # # Other size-limiting definitions # define(CONTEXT_STACK_SIZE,1024) define(DATA_STACK_SIZE,4096) define(PROG_STACK_SIZE,1024) define(NODE_SIZE,3) define(OBLIST_LENGTH,192) define(MAX_SUBR_ARGS,5) define(LINE_LENGTH,72) define(MAX_STRING,512) define(QUEUE_LENGTH,31) define(MAX_INPUT_LEVELS,16) # # These are the allowable error codes passed to ERRLG. # define(ARITH_ERROR,1) define(STRING_ERROR,2) define(INCOMP_ERROR,3) define(ARRAY_SPEC_ERROR,4) define(ARRAY_SPACE_ERROR,5) define(SUBSCRIPT_ERROR,6) define(SEVERE_ERROR,7) define(UNBOUND_ERROR,8) define(CANT_EVAL_ERROR,9) define(IO_ERROR,10) define(NOPROG_ERROR,11) define(LIST_ERROR,12) define(ARGUMENT_ERROR,13) # # These are the allowable values for errlg to tell the user what kind # of value he should return through BREAK. # define(NUMERIC_VALUE,1) define(STRING_VALUE,2) define(TRUTH_VALUE,3) define(FUNCTION_VALUE,4) define(ANYTHING,5) define(RESTART_LISP,6) define(ATOMIC_VALUE,7) # This symbol is used on CPUs without stacks. It should occur at the # beginning of every potentially recursive function. define(ENTRY_POINT,) # This is also used on machines without stacks. define(RETURN_VALUE,return($1)) define(PUSH,call psha) define(POP,ipopa()) define(PUSH_REGISTERS,call rgpsh) define(POP_REGISTERS,call rgpop) define(NULL,0) define(NIL,0) define(T,-1) define(QUOTESYMBOL,SQUOTE) define(WILDCARDCHAR,10) define(COMMENTCHAR,';') # # Some datatypes # define(PREDICATE,integer function) define(LISPVAL,integer) define(ADDRESS,integer) define(READSEG,2) define(PRINTSEG,3) define(ENDOFSTACK,-2) define(INUM,512) define(QUNBOUND,qubnd) # Offset of UNBOUND in "lists". define(QVALUE,qvalu) # Offset of VALUE. define(QPNAME,qpnam) # Offset ofPNAME # # Macros defining subroutine and function calls # define(READCH,readh) define(PRINTCH,call prinh) define(TERPRI,call terpi) define(BACKSP,call backp) define(INSERT,call inset) define(DOT_PRINT,call dotpt) define(MAKSTRING,maksg) define(INTERN,inten) define(PSTRING,pstrg) define(STRINGP,strgp) define(PUTPROP,ptprp) define(DEFPROP,dfprp) define(SYMBOLP,symbp) define(PSYMBOL,psyml) define(QPRINT,qprnt) define(QERROR,zzzerr) define(QRPLACA,qrpla) define(QRPLACD,qrpld) define(QSYMBOLP,qsymp) define(QSTRINGP,qstrp) define(QDEFPROP,qdfpr) define(QPUTPROP,qptpr) define(QEQUAL,qequl) define(NUMBERP,nump) define(QMINUS,qmns) define(QTIMES,qtmes) define(QDIVIDE,qdivd) define(DIVIDE,divd) define(QFSUBR,qfsbr) define(QLAMBDA,qlmbda) define(QBINDING,qbnd) define(UNBIND,unbnd) define(QNUMBERP,qnump) define(TOPOFLISP,tlrtn) define(QTOPLEVEL,qtplv) define(TOPLEVEL,toplv) define(CLEARSTACK,call clstk) define(QRETURN,qretn) define(QGREATRP,qgrtp) define(QACCESS,qaces) define(PUSH_CONTEXT,call cpush) define(POP_CONTEXT,call cpop) define(CURRSEG,crsg01) define(QICHANNEL,zzzchn) define(QOCHANNEL,yyychn) # # The function 'addrs' may have to be a real function on some machines. define(addrs,%loc) # ifdef(LARGE_ADDRESS_SPACE) define(LOAD_SEGMENT_IF_NECESSARY,# $1) elsedef define(LOAD_SEGMENT_IF_NECESSARY,call lodsg( $1, 0, 0, 0, 0, 0)) enddef # # Macros for explicit manipulation of the list node fields. # define(AUX_FIELD,lists($1-1)) define(CAR_FIELD,lists($1)) define(CDR_FIELD,lists($1+1)) # # These are symbols for performing some of the very frequent data # base access. They were once functions and subroutines but now # they are MACROs. define(car,lists($1)) define(cdr,lists($1+1)) define(DEPOSIT,lists($2) = $1) define(EXAMINE,lists($1)) define(RPLACA,lists($1) = $2) define(RPLACD,lists($1+1) = $2) # This is what the should be if they made into subroutines. # define(DEPOSIT,call depot) # define(EXAMINE,exame) # define(RPLACA,rplaa) # define(RPLACD,rplad) # The allowable suffixes for (ASCII) lisp files. define(LISP_SUFFIX,"@e.lsp@e@n") # The initial file to load. define(LISP_INIT,"inilsp") # # Definitions for ROLLIN and ROLLOUT # define(FIRST_NODE,(INUM+2)) define(LAST_NODE,(((((DATA_SPACE-INUM)/NODE_SIZE)-1)*NODE_SIZE)+2+INUM)) define(ROLLOUT_BLOCK_SIZE,512) define(ROLLIN_SUFFIX,"@e.rol@e@n") define(ROLLIN_INIT,"inirol") # # Definitions for the string space garbage collector. # define(STRING_START,arrays(($1-1)*NODE_SIZE+base)) define(STRING_LENGTH,arrays(($1-1)*NODE_SIZE+base+1)) define(NODE_ADDRESS,arrays(($1-1)*NODE_SIZE+base+2)) # # Definitions for the garbage collectors and the compressor. # define(EVERY_NODE,$1=FIRST_NODE;$1<=LAST_NODE;$1=$1+NODE_SIZE) define(NODE_IS_MARKED,iand(AUX_FIELD($1),MARK_BIT)!=0) define(NODE_IS_NOT_MARKED,iand(AUX_FIELD($1),MARK_BIT)==0) define(MARK_NODE,AUX_FIELD($1)=ior(AUX_FIELD($1),MARK_BIT)) define(UNMARK_NODE,AUX_FIELD($1)=iand(AUX_FIELD($1),not(MARK_BIT))) define(NODE_IS_TAGGED,iand(AUX_FIELD($1),TAG_BIT)!=0) define(NODE_IS_NOT_TAGGED,iand(AUX_FIELD($1),TAG_BIT)==0) define(TAG_NODE,AUX_FIELD($1)=ior(AUX_FIELD($1),TAG_BIT)) define(UNTAG_NODE,AUX_FIELD($1)=iand(AUX_FIELD($1),not(TAG_BIT))) define(NODE_IS_ATOM_HEADER,iand(AUX_FIELD($1),ATOM_HEADER)!=0) define(NODE_IS_NOT_ATOM_HEADER,iand(AUX_FIELD($1),ATOM_HEADER)==0) #-t- defns 5767 ascii 15-Jan-84 13:57:15 #-h- lspdt 327 ascii 15-Jan-84 13:57:16 block data lspdt include lspcm data inpstk(1) /STDIN/ data output /STDOUT/ data defin /STDIN/ data defout /STDOUT/ data icptr /0/ data inplvl /1/ data icbuf /MAXLINE*' '/ data oblen /OBLIST_LENGTH/ data level /0/ data cptr /1/ data prptr /1/ data pcptr /0/ data CURRSEG /0/ data symcnt /0/ data press /NO/ end #-t- lspdt 327 ascii 15-Jan-84 13:57:16 #-h- main 1031 ascii 15-Jan-84 13:57:16 DRIVER(lisp) include lspcm include cflag include lspem define(START,1000) PB_DECL(MAXLINE) # push-back buffer for line-editing character argbuf(FILENAMESIZE), c integer ev, i, junk, rd integer getarg, ldfil, rolin, rtrvsp # function(s) LISPVAL eval, jcall, reade string tprmt "-->" string usestr "? Usage: lisp [-b] [-q] [-v] [file] ..." data bare /NO/ data quiet /NO/ data verbos /NO/ call pbinit(MAXLINE) # Initialize push-back buffer. assign START to TOPOFLISP savedsp = rtrvsp() call query(usestr) call flags( argbuf, FILENAMESIZE) # Process flags if( bare == YES ) call init else if( rolin(ROLLIN_INIT) == NIL ) { call init junk = ldfil(LISP_INIT) } for( i = 1 ; getarg( i, argbuf, FILENAMESIZE) != EOF ; i = i + 1 ) junk = ldfil(argbuf) START continue repeat { call strcpy( tprmt, rprmt) rd = reade() areg = rd ev = eval() if( rd == NIL & ev == NIL ) call inpop else { LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = ev i = jcall(printf) TERPRI } } DRETURN end #-t- main 1031 ascii 15-Jan-84 13:57:16 #-h- init 6105 ascii 15-Jan-84 13:57:17 ### Init Initialization routine for LISP. subroutine init include lspcm external DEFPROP, PUTPROP, get, equal2 external eval external TOPLEVEL external list external cls, load, inpush, opnfil, cr8fil, getln, putln, prmpt external brkp external flshp, flshr external extfn, rlin2, rlout external andf, orf, floop, wloop external cond external prog, retrn, go external car2, cdr2, cons2, rpla2, rpld2, sym2, str2, atm2 external eq2, quot2, nul2, set, setq, num2 external gc, store, gcs external rderr, dmemb, diml # This is the function which is called just before # entering the top level READ-EVAL-PRINT loop # of the LISP interpreter. The function INTERNs # several ATOMs and puts the entry points of # the SUBRs (compilied functions) on their PROPERTY # LISTs. This is the file which must be modified # and re-compiled in order to add new SUBRs and # FSUBRs to this LISP system. LSPIN only does # the initialization for the functions which are # contained in the main. # Before we can start interning ATOMS we must have # 3 ATOMS, 'VALUE, 'UNBOUND & 'PNAME. These variables # are used in doing so. integer u, v, p, su, sv, sp, atu, atv, atp integer hash integer n, i, j, k, l LISPVAL INTERN, makfn, PUTPROP LISPVAL r, b, d LISPVAL MAKSTRING LISPVAL mksym call emait # This section of code "MANUALLY" INTERNS the # ATOMs UNBOUND, VALUE, and PNAME which are required # to INTERN any other ATOMs. u = hash("unbound") # Find the hash values for these v = hash("value") # ATOMs in order to put them on the p = hash("pname") # OBLIST. # It is important that these three hash values be distinct. if( u == v | u == p | v == p ) call error( "? Error in hashing." ) su = MAKSTRING("unbound") # Put the names in the DATA_SPACE. sv = MAKSTRING("value") sp = MAKSTRING("pname") atu = mksym() # Create the ATOM. atv = mksym() atp = mksym() # Here we stick the PROPERTY LIST on each ATOM. RPLACD( atu, cons( atv, cons( atu, cons( atp, cons( su, NIL))))) RPLACD( atv, cons( atv, cons( atu, cons( atp, cons( sv, NIL))))) RPLACD( atp, cons( atv, cons( atu, cons( atp, cons( sp, NIL))))) RPLACA( atu, atu) RPLACA( atv, atu) RPLACA( atp, atu) # Set the ATOM so we can use it later. QUNBOUND = atu QVALUE = atv QPNAME = atp # Put the ATOMs on the OBLIST. oblist(u) = cons( cons( QUNBOUND, su), NIL) oblist(v) = cons( cons( QVALUE, sv), NIL) oblist(p) = cons( cons( QPNAME, sp), NIL) # The following lines INTERN the ATOMs which the # the LISP system must know in order to operate. qsubr = INTERN("subr") QFSUBR = INTERN("fsubr") QLAMBDA = INTERN("lambda") qmacro = INTERN("macro") qrmac = INTERN("read_macro") qlabel = INTERN("label") qlsubr = INTERN("lsubr") QICHANNEL = INTERN("ichannel") QOCHANNEL = INTERN("ochannel") QBINDING = INTERN("binding") call setvl( QBINDING, NIL) qexpr = INTERN("expr") qfexpr = INTERN("fexpr") QDEFPROP = makfn( "defprop", QFSUBR, addrs(DEFPROP)) i = makfn( "flushprint", qsubr, addrs(flshp)) i = makfn( "flushread", qsubr, addrs(flshr)) i = makfn( "exit", qsubr, addrs(extfn)) i = makfn( "getlin", qsubr, addrs(getln)) i = makfn( "putlin", qsubr, addrs(putln)) i = makfn( "prompt", qsubr, addrs(prmpt)) # # Symbols for file access modes # QRDACC = INTERN("READ") QWRACC = INTERN("WRITE") QAPACC = INTERN("APPEND") qdot = INTERN("dot") qblnk = INTERN("blank") qlpar = INTERN("lpar") qrpar = INTERN("rpar") qlbrkt = INTERN("[") qrbrkt = INTERN("]") b = INTERN(" ") l = INTERN("(") r = INTERN(")") d = INTERN(".") areg = qdot breg = d creg = QVALUE n = PUTPROP() areg = qblnk breg = b creg = QVALUE n = PUTPROP() areg = qlpar breg = l creg = QVALUE n = PUTPROP() areg = qrpar breg = r creg = QVALUE n = PUTPROP() qdot = d qblnk = b qlpar = l qrpar = r qquote = INTERN("'") qcar = makfn( "car", qsubr, addrs(car2)) qcdr = makfn( "cdr", qsubr, addrs(cdr2)) qcons = makfn( "cons", qsubr, addrs(cons2)) QRPLACA = makfn( "rplaca", qsubr, addrs(rpla2)) QRPLACD = makfn( "rplacd", qsubr, addrs(rpld2)) i = makfn( "diml", qsubr, addrs(diml)) QSYMBOLP = makfn( "symbolp", qsubr, addrs(sym2)) QSTRINGP = makfn( "stringp", qsubr, addrs(str2)) qatom = makfn( "atom", qsubr, addrs(atm2)) qeq = makfn( "eq", qsubr, addrs(eq2)) quote = makfn( "quote", QFSUBR, addrs(quot2)) qnull = makfn( "null", qsubr, addrs(nul2)) qset = makfn( "set", qsubr, addrs(set)) qsetq = makfn( "setq", QFSUBR, addrs(setq)) QNUMBERP = makfn( "numberp", qsubr, addrs(num2)) QPUTPROP = makfn( "putprop", qsubr, addrs(PUTPROP)) qget = makfn( "get", qsubr, addrs(get)) QEQUAL = makfn( "equal", qsubr, addrs(equal2)) equalf = addrs(equal2) qeval = makfn( "eval", qsubr, addrs(eval)) evalf = addrs(eval) qload = makfn( "load", qsubr, addrs(load)) QTOPLEVEL = makfn( "toplevel", qsubr, addrs(TOPLEVEL)) i = makfn( "open", qsubr, addrs(opnfil)) i = makfn( "create", qsubr, addrs(cr8fil)) i = makfn( "inpush", qsubr, addrs(inpush)) i = makfn( "close", qsubr, addrs(cls)) clsf = addrs(cls) # This section is the same as for the other # implicit functions except that the functions are # FSUBRs and so the argument list is passed # unEVALuated. Any function which has an indefinite # number of arguments must be implemented in this way. qlist = makfn( "list", QFSUBR, addrs(list)) qbrkp = makfn( "break", QFSUBR, addrs(brkp)) i = makfn( "and", QFSUBR, addrs(andf)) i = makfn( "or", QFSUBR, addrs(orf)) QRETURN = makfn( "return", qsubr, addrs(retrn)) qcond = makfn( "cond", QFSUBR, addrs(cond)) qprog = makfn( "prog", QFSUBR, addrs(prog)) qgo = makfn( "go", QFSUBR, addrs(go)) qwhile = makfn( "while", QFSUBR, addrs(wloop)) qfor = makfn( "for", QFSUBR, addrs(floop)) qgc = makfn( "gc", qsubr, addrs(gc)) i = makfn( "gcs", qsubr, addrs(gcs)) i = makfn( "rollin", qsubr, addrs(rlin2)) i = makfn( "rollout", qsubr, addrs(rlout)) qstore = makfn( "store", QFSUBR, addrs(store)) QERROR = INTERN("--ERROR++") i = makfn( "readerr", qsubr, addrs(rderr)) i = makfn( "dmember", qsubr, addrs(dmemb)) dmembf = addrs(dmemb) # We call LODSG to load in each of the segments containing # compiled functions so that they can INTERN their functions. for( i = 1 ; i <= 5 ; i = i + 1 ) call lodsg( i, -1, 0, 0, 0, 0) return end #-t- init 6105 ascii 15-Jan-84 13:57:17 #-h- absv 294 ascii 15-Jan-84 13:57:17 ### AbsV Return the absolute value. LISPVAL function absv() include lspcm LISPVAL i LISPVAL mknum, NUMBERP real numvl i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( abs( numvl(i)))) end #-t- absv 294 ascii 15-Jan-84 13:57:17 #-h- access 1212 ascii 15-Jan-84 13:57:18 ### Access Used by EVAL to access arrays. Does bounds checking. LISPVAL function acces() include lspcm include lspem integer ndim integer dim integer min, max, index ADDRESS gtent real numvl LISPVAL dlst LISPVAL arry LISPVAL NUMBERP, subrp integer ele integer p arry = areg # Get the array header dlst = breg # Get the element if( subrp( cdr(arry)) == NIL ) { call errlg( ARRAY_SPEC_ERROR, ANYTHING) return(QERROR) } p = gtent( cdr(arry)) # Get the start address of the block ndim = arrays(p) # The number of dimensions of the array dim = 0 ele = 0 while( dlst != NIL ) { dim = dim + 1 if( dim > ndim ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) return(QERROR) } if( NUMBERP( car(dlst)) == NIL ) { call errlg( ARRAY_SPEC_ERROR, ANYTHING) return(QERROR) } index = numvl( car(dlst)) min = arrays( p + 2 * dim - 1 ) max = arrays( p + 2 * dim ) if( index < min | index > max ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) return(QERROR) } ele = ele * ( max - min + 1 ) + ( index - min ) dlst = cdr(dlst) } if( dim != ndim ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) return(QERROR) } ele = ele + 1 return( arrays( p + ndim * 2 + ele )) end #-t- access 1212 ascii 15-Jan-84 13:57:18 #-h- acosx 482 ascii 15-Jan-84 13:57:18 ### Acosx Return the arc cosine of x. LISPVAL function acosx() include lspcm LISPVAL mknum, NUMBERP # function(s) LISPVAL i real acos, numvl # function(s) real val i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef val = numvl(i) ifdef( CHECK_ARGUMENTS ) if( val < -1.0 | val > 1.0 ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( acos( val))) end #-t- acosx 482 ascii 15-Jan-84 13:57:18 #-h- add1 325 ascii 15-Jan-84 13:57:19 ### Add1 Add 1 to a number. LISPVAL function add1() include lspcm LISPVAL i LISPVAL mknum, NUMBERP # functions(s) real numvl # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE ) return(QERROR) } enddef ab = numvl(i) return( mknum( ab + 1.0 )) end #-t- add1 325 ascii 15-Jan-84 13:57:19 #-h- adjust 690 ascii 15-Jan-84 13:57:19 ### Adjust Used by "hsort" in sorting the list of string nodes. subroutine adjust( i, n) include lspcm include cgcs integer i, n integer start, len, node, j start = STRING_START(i) len = STRING_LENGTH(i) node = NODE_ADDRESS(i) j = i * 2 while( j <= n ) { if( j < n & STRING_START(j) < STRING_START(j + 1) ) j = j + 1 if( start >= STRING_START(j) ) { STRING_START(j/2) = start STRING_LENGTH(j/2) = len NODE_ADDRESS(j/2) = node return } STRING_START(j/2) = STRING_START(j) STRING_LENGTH(j/2) = STRING_LENGTH(j) NODE_ADDRESS(j/2) = NODE_ADDRESS(j) j = j * 2 } STRING_START(j/2) = start STRING_LENGTH(j/2) = len NODE_ADDRESS(j/2) = node return end #-t- adjust 690 ascii 15-Jan-84 13:57:19 #-h- allct 1387 ascii 15-Jan-84 13:57:19 subroutine allct( m, p) # The data management algorithms are from Horowitz and Sahni, # Fundamentals of Data Structures under Doublely Linked Lists # for Dynamic Storage Management. # The routine ALLCT allocates a block of size "m" to the caller # and returns its offset in "p" include lspcm include lspem define(EPSILON,25) integer p, n, diff, m n = m + 3 # We need 3 words for overhead p = arrays( av + 3 ) # AV is the available storage list. # We go through the entire available storage list looking for the first # block which fits. repeat { if( arrays( p + 1 ) >= n ) { diff = arrays( p + 1 ) - n if( diff < EPSILON ) # EPSILON is the smallest block we will save { arrays( arrays( p + 2 ) + 3 ) = arrays( p + 3 ) # Allocate the arrays( arrays( p + 3 ) + 2 ) = arrays( p + 2 ) # entire block. arrays(p) = 1 arrays( p + arrays( p + 1 ) - 1 ) = 1 av = arrays( p + 2 ) p = p + 2 return } else # Otherwise just take the lower portion. { arrays( p + 1 ) = diff arrays( p + diff - 2 ) = p arrays( p + diff - 1 ) = 0 av = p p = p + diff arrays( p + 1 ) = n arrays(p) = 1 arrays( p + n - 1 ) = 1 p = p + 2 return } } p = arrays( p + 3 ) } until( p == arrays( av + 3 )) # Go through the list until we are back where we started. p = NIL return end #-t- allct 1387 ascii 15-Jan-84 13:57:19 #-h- andf 339 ascii 15-Jan-84 13:57:20 ### Andf AND 1 or more arguments. Stop if a NIL arg. is encountered. PREDICATE andf() include lspcm LISPVAL arglst, tval LISPVAL eval # function(s) ENTRY_POINT andf = NIL arglst = areg tval = T while( arglst != NIL & tval != NIL ) { PUSH(arglst) areg = car(arglst) tval = eval() arglst = cdr(POP) } RETURN_VALUE(tval) end #-t- andf 339 ascii 15-Jan-84 13:57:20 #-h- array 1967 ascii 15-Jan-84 13:57:20 ### Array Allocate storage for an array and return the header. # LSUBR LISPVAL function array() include lspcm include lspem LISPVAL arglst, dlst LISPVAL mksbr, NUMBERP # function(s) integer i, ndim, p, size real numvl arglst = areg ndim = 0 # We will count the number of dimensions. size = 1 # and compute the size of block. dlst = arglst while( dlst != NIL ) { # Dimension specs can be either single numbers or dotted pairs if( NUMBERP( car(dlst)) == T ) { ndim = ndim + 1 if( ifix( numvl( car(dlst))) < 0 ) { call errlg( SUBSCRIPT_ERROR, FUNCTION_VALUE) return(QERROR) } size = size * ( ifix( numvl( car(dlst))) + 1 ) } else if( NUMBERP( car( car(dlst))) == T & NUMBERP( cdr( car(dlst))) == T ) { if( numvl( car( car(dlst))) > numvl( cdr( car(dlst)))) { call errlg( SUBSCRIPT_ERROR, FUNCTION_VALUE) return(QERROR) } ndim = ndim + 1 size = size * ( ifix( numvl( cdr( car(dlst)))) - ifix( numvl( car( car(dlst)))) + 1 ) } else { call errlg( ARRAY_SPEC_ERROR, FUNCTION_VALUE) return(QERROR) } dlst = cdr(dlst) } # The size of the block is the data area requested plus one word # for the number of dimensions and one word for each upper and # lower bound. call allct( size + ndim * 2 + 1, p) if( p == NIL ) { call errlg( ARRAY_SPACE_ERROR, FUNCTION_VALUE) return(QERROR) } array = cons( qarray, mksbr(p)) # Set up the array header arrays(p) = ndim dlst = arglst for( i = 1 ; i <= ndim * 2 ; i = i + 2 ) { if( NUMBERP( car(dlst)) == T ) { arrays( p + i ) = 0 # The default lower bound is zero. arrays( p + i + 1 ) = ifix( numvl( car(dlst))) } else { arrays( p + i ) = ifix( numvl( car( car(dlst)))) arrays( p + i + 1 ) = ifix( numvl( cdr( car(dlst)))) } dlst = cdr(dlst) } # Initialize the array elements to NIL. for( i = ndim * 2 + 1 ; i <= size + ndim * 2 ; i = i + 1 ) arrays( p + i ) = NIL return end #-t- array 1967 ascii 15-Jan-84 13:57:20 #-h- asinx 479 ascii 15-Jan-84 13:57:21 ### Asinx Return the arc sine of x. LISPVAL function asinx() include lspcm LISPVAL i LISPVAL mknum, NUMBERP # function(s) real val real asin, numvl # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef val = numvl(i) ifdef( CHECK_ARGUMENTS ) if( val < -1.0 | val > 1.0 ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( asin( val))) end #-t- asinx 479 ascii 15-Jan-84 13:57:21 #-h- atanx 561 ascii 15-Jan-84 13:57:21 ### Atanx Return the arc tangent of x/y. LISPVAL function atanx() include lspcm LISPVAL x, y LISPVAL mknum, NUMBERP # function(s) real rslt, xval, yval real numvl, atan2 # function(s) x = areg y = breg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(x) == NIL | NUMBERP(y) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef xval = numvl(x) yval = numvl(y) if( yval == 0.0 ) # return pi/2 with the sign of x { rslt = 1.5707963 # pi/2 if( xval < 0.0 ) rslt = -rslt } else rslt = atan2( xval, yval) return( mknum( rslt)) end #-t- atanx 561 ascii 15-Jan-84 13:57:21 #-h- atm2 92 ascii 15-Jan-84 13:57:22 LISPVAL function atm2() include lspcm LISPVAL atom # function(s) return( atom(areg)) end #-t- atm2 92 ascii 15-Jan-84 13:57:22 #-h- atom 244 ascii 15-Jan-84 13:57:22 ### Atom Determine whether or not the argument is an ATOM. PREDICATE atom(i) include lspcm LISPVAL i if( i == NIL | i == T | i <= INUM ) atom = T else if( iand( ATOM_HEADER, AUX_FIELD(i)) == 0 ) atom = NIL else atom = T return end #-t- atom 244 ascii 15-Jan-84 13:57:22 #-h- backp 157 ascii 15-Jan-84 13:57:22 ### BackP Backspace the input pointer. subroutine backp include lspcm if( icptr <= 0 ) call error( "? Can't backspace.") icptr = icptr - 1 return end #-t- backp 157 ascii 15-Jan-84 13:57:22 #-h- bind 1552 ascii 15-Jan-84 13:57:23 ### Bind Bind values to a list of variables. ### Bind takes two parameters, a list of variables to bind, ### and a parameter list to EVALuate and bind to the variables. ### See the users manual for possible formats. PREDICATE bind() include lspcm LISPVAL varlst, parlst, dstlst LISPVAL bdlst, cell, tval LISPVAL atom, eval, getvl # function(s) ENTRY_POINT bind = NIL varlst = areg # Get the variable list. parlst = breg # Get the parameter list dstlst = NIL # dstlst is the distination list for the evaluated params. while( atom(varlst) == NIL ) # As long as we have a list structure. { PUSH(parlst) PUSH(varlst) PUSH(dstlst) # NOTE: Here we are using the fact that the CAR of NIL is NIL # to be able to call functions with too few actual parameters. areg = car(parlst) # EVALuate the parameters. tval = eval() dstlst = POP varlst = POP parlst = POP dstlst = cons( cons( car(varlst), tval), dstlst) varlst = cdr(varlst) parlst = cdr(parlst) } # If there is a Special parameter put the remainder of the # parameters unEVALuated there. if( varlst != NIL ) dstlst = cons( cons( varlst, parlst), dstlst) bdlst = getvl(QBINDING) # Get the current binding context. while( dstlst != NIL ) { # Take each of the cells in the destination list and swap the # new and old values. cell = car(dstlst) tval = getvl( car(cell)) call setvl( car(cell), cdr(cell)) RPLACD( cell, tval) bdlst = cons( cell, bdlst) dstlst = cdr(dstlst) } call setvl( QBINDING, bdlst) # The new binding context. RETURN_VALUE(T) end #-t- bind 1552 ascii 15-Jan-84 13:57:23 #-h- brkp 856 ascii 15-Jan-84 13:57:23 ### Break Implement the BREAK package. ### If IRTN is non-NIL BRKP will return a value. LISPVAL function brkp(irtn) include lspcm character bprmt(6) integer i, j, len integer itoc # function(s) LISPVAL irtn LISPVAL eval, jcall, reade # function(s) ENTRY_POINT level = level + 1 brkp = NIL inplvl = 1 inpstk(inplvl) = STDIN output = STDOUT repeat { len = itoc( level, bprmt, 4) bprmt( len + 1 ) = COLON bprmt( len + 2 ) = EOS call strcpy( bprmt, rprmt) i = reade() if( i == QRETURN ) { LOAD_SEGMENT_IF_NECESSARY( READSEG ) i = jcall(readfn) PUSH(level) areg = i i = eval(i) level = POP level = level - 1 RETURN_VALUE(i) } PUSH(level) areg = i j = eval() level = POP LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = j i = jcall(printf) TERPRI } level = level - 1 RETURN_VALUE(NIL) end #-t- brkp 856 ascii 15-Jan-84 13:57:23 #-h- caar 240 ascii 15-Jan-84 13:57:24 LISPVAL function caar() include lspcm LISPVAL arg, atom arg = areg ifdef( CHECK_ARGUMENTS ) if( atom(arg) == T | atom( car(arg)) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( car( car(arg))) end #-t- caar 240 ascii 15-Jan-84 13:57:24 #-h- cadr 239 ascii 15-Jan-84 13:57:24 LISPVAL function cadr() include lspcm LISPVAL arg, atom arg = areg ifdef( CHECK_ARGUMENTS ) if( atom(arg) == T | atom( cdr(arg)) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( car( cdr(arg))) end #-t- cadr 239 ascii 15-Jan-84 13:57:24 #-h- car 114 ascii 15-Jan-84 13:57:24 #function car(i) #include lspcm #LISPVAL i # #if( i == NIL | i == T ) # car = NIL #else # car = EXAMINE(i) #end #-t- car 114 ascii 15-Jan-84 13:57:24 #-h- car2 220 ascii 15-Jan-84 13:57:25 LISPVAL function car2() include lspcm LISPVAL i LISPVAL atom, SYMBOLP i = areg ifdef( CHECK_ARGUMENTS ) if( atom(i) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( car(i)) end #-t- car2 220 ascii 15-Jan-84 13:57:25 #-h- cdar 240 ascii 15-Jan-84 13:57:25 LISPVAL function cdar() include lspcm LISPVAL arg, atom arg = areg ifdef( CHECK_ARGUMENTS ) if( atom(arg) == T | atom( car(arg)) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( cdr( car(arg))) end #-t- cdar 240 ascii 15-Jan-84 13:57:25 #-h- cddr 240 ascii 15-Jan-84 13:57:25 LISPVAL function cddr() include lspcm LISPVAL arg, atom arg = areg ifdef( CHECK_ARGUMENTS ) if( atom(arg) == T | atom( cdr(arg)) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( cdr( cdr(arg))) end #-t- cddr 240 ascii 15-Jan-84 13:57:25 #-h- cdr 116 ascii 15-Jan-84 13:57:26 #function cdr(i) #include lspcm #LISPVAL i # #if( i == NIL | i == T ) # cdr = NIL #else # cdr = EXAMINE(i+1) #end #-t- cdr 116 ascii 15-Jan-84 13:57:26 #-h- cdr2 220 ascii 15-Jan-84 13:57:26 LISPVAL function cdr2() include lspcm LISPVAL i LISPVAL atom, SYMBOLP i = areg ifdef( CHECK_ARGUMENTS ) if( atom(i) == T ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef return( cdr(i)) end #-t- cdr2 220 ascii 15-Jan-84 13:57:26 #-h- chget 303 ascii 15-Jan-84 13:57:27 character function chget( istrg, i) include lspcm include lspem LISPVAL istrg integer i, iwrd integer strln # function(s) LISPVAL STRINGP iwrd = i if( STRINGP(istrg) == NIL ) return(NULL) else if( i > strln(istrg)) return(NULL) else return( strngs( iwrd - 1 + EXAMINE( istrg + 1 ))) end #-t- chget 303 ascii 15-Jan-84 13:57:27 #-h- chrps 163 ascii 15-Jan-84 13:57:27 ### ChrPs Return the current character position of the print buffer. LISPVAL function chrps() include lspcm LISPVAL mknum return( mknum( float(pcptr))) end #-t- chrps 163 ascii 15-Jan-84 13:57:27 #-h- cls 287 ascii 15-Jan-84 13:57:27 ### Close Close an i/o channel. integer function cls() include lspcm integer gtent integer i LISPVAL chan chan = areg if( car(chan) != QICHANNEL & car(chan) != QOCHANNEL ) { call errlg( IO_ERROR, RESTART_LISP) return(QERROR) } i = gtent( cdr(chan)) call close(i) return(T) end #-t- cls 287 ascii 15-Jan-84 13:57:27 #-h- cnumo 299 ascii 15-Jan-84 13:57:28 ### CNumO Format integer as a HEX string. subroutine cnumo( n, buf) character buf(ARB) integer n integer i string digstr "0123456789ABCDEF" call sfill( buf, 1, 20, ' ') i = n icnt = 8 repeat { buf(icnt) = digstr( mod( i, 16) + 1) icnt = icnt - 1 i = i / 16 } until( i == 0 ) return end #-t- cnumo 299 ascii 15-Jan-84 13:57:28 #-h- comp 2658 ascii 15-Jan-84 13:57:28 integer function comp() include lspcm include lspem integer clrwrd, freect, fstnd, iend, istart, lstnd, ndim, usedwd integer i, n, p freect = 0 for( EVERY_NODE(i) ) if( NODE_IS_NOT_MARKED(i) ) freect = freect + 1 usedwd = LAST_NODE - freect * NODE_SIZE lstnd = LAST_NODE fstnd = FIRST_NODE repeat { while( NODE_IS_NOT_MARKED(lstnd) & lstnd > usedwd ) lstnd = lstnd - NODE_SIZE while( NODE_IS_MARKED(fstnd) ) fstnd = fstnd + NODE_SIZE if( lstnd <= usedwd ) break AUX_FIELD(fstnd) = AUX_FIELD(lstnd) RPLACA( fstnd, car(lstnd)) RPLACD( fstnd, cdr(lstnd)) RPLACA( lstnd, fstnd) AUX_FIELD(lstnd) = 0 } ifdef( DEBUG ) for( i = FIRST_NODE ; i <= usedwd ; i = i + NODE_SIZE ) if( NODE_IS_NOT_MARKED(i) ) { call remark("? Didn't find mark bit.") pause } for( i = usedwd + NODE_SIZE ; i <= LAST_NODE ; i = i + NODE_SIZE ) if( NODE_IS_MARKED(i) ) { call remark("Found a mark bit.") pause } enddef for( i = FIRST_NODE ; i <= usedwd ; i = i + NODE_SIZE ) { if( iand( AUX_FIELD(i), ATOM_HEADER) != 0 & iand( AUX_FIELD(i), SYMBOL_BIT) == 0 ) next if( car(i) > usedwd ) RPLACA( i, car( car(i))) if( cdr(i) > usedwd ) RPLACD( i, car( cdr(i))) ifdef( DEBUG ) if( NODE_IS_NOT_MARKED(i) ) { call remark("? Oops! This isn't marked.") pause } enddef } # Here we see all the places that the compressor has to look. # THE OBLIST for( i = 1 ; i <= OBLIST_LENGTH ; i = i + 1 ) if( oblist(i) > usedwd ) oblist(i) = car( oblist(i)) # THE DATA STACK for( i = 1 ; i <= dsp ; i = i + 1 ) if( dstack(i) > usedwd ) dstack(i) = car( dstack(i)) # THE CONTEXT STACK for( i = 1 ; i <= cptr - 1 ; i = i + 1 ) if( cstk(i) > usedwd ) cstk(i) = car( cstk(i)) # The last few nodes allocated from the heap (just in case). for( i = 0 ; i <= QUEUE_LENGTH ; i = i + 1 ) if( cqueue(i) > usedwd ) cqueue(i) = car( cqueue(i)) # All the nodes reachable from the arrays p = 7 repeat { n = arrays( p + 1 ) if( arrays(p) != 1 ) p = p + n else { ndim = arrays( p + 2 ) istart = p + 3 + ndim * 2 iend = p + n - 3 for( i = istart ; i <= iend ; i = i + 1 ) if( arrays(i) > usedwd ) arrays(i) = car( arrays(i)) p = p + n } } until( p == ARRAY_SPACE ) # Now we collect all the unmarked nodes and clear the two bits we used. lptr = NIL nodect = 0 clrwrd = iand( not(TAG_BIT), not(MARK_BIT)) for( EVERY_NODE(i) ) { if( NODE_IS_NOT_MARKED(i) ) { CAR_FIELD(i) = lptr AUX_FIELD(i) = FREE_BIT lptr = i nodect = nodect + 1 } else AUX_FIELD(i) = iand( AUX_FIELD(i), clrwrd) } return(T) end #-t- comp 2658 ascii 15-Jan-84 13:57:28 #-h- conct 519 ascii 15-Jan-84 13:57:29 ### Conct Concatenate args into a string. LISPVAL function conct() include lspcm character buf(MAX_STRING) # Should use a scratch buffer. LISPVAL MAKSTRING integer i, junk integer stget LISPVAL arglst, str LISPVAL STRINGP arglst = areg i = 1 while( arglst != NIL ) { str = car( arglst) ifdef( CHECK_ARGUMENTS ) if( STRINGP(str) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef junk = stget( str, buf, i) arglst = cdr(arglst) } return( MAKSTRING(buf)) end #-t- conct 519 ascii 15-Jan-84 13:57:29 #-h- cond 624 ascii 15-Jan-84 13:57:29 LISPVAL function cond() include lspcm LISPVAL arglst, condt, form, value LISPVAL eval, sevl # function(s) ENTRY_POINT # This is a recursive function as it calls EVAL. cond = NIL arglst = areg # Fetch the argument list. if( arglst == NIL ) RETURN_VALUE(NIL) repeat { PUSH(arglst) areg = car( car(arglst)) condt = eval() arglst = POP form = cdr( car(arglst)) arglst = cdr(arglst) } until( arglst == NIL | condt != NIL ) if( condt == NIL ) RETURN_VALUE(NIL) else { areg = form value = sevl() # EVALuate the forms in the list and return # the value of the last one. RETURN_VALUE(value) } end #-t- cond 624 ascii 15-Jan-84 13:57:29 #-h- cons 153 ascii 15-Jan-84 13:57:30 function cons( i, j) include lspcm LISPVAL i, j LISPVAL p, heap p = heap() DEPOSIT( NIL, p - 1 ) DEPOSIT( i, p) DEPOSIT( j, p + 1 ) return(p) end #-t- cons 153 ascii 15-Jan-84 13:57:30 #-h- cons2 102 ascii 15-Jan-84 13:57:30 LISPVAL function cons2() include lspcm LISPVAL i, j i = areg j = breg return( cons( i, j)) end #-t- cons2 102 ascii 15-Jan-84 13:57:30 #-h- cosx 313 ascii 15-Jan-84 13:57:30 ### Cosx Return the cosine of an angle in radians. LISPVAL function cosx() include lspcm LISPVAL i LISPVAL mknum, NUMBERP real cos, numvl i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( cos( numvl(i)))) end #-t- cosx 313 ascii 15-Jan-84 13:57:30 #-h- cpop 144 ascii 15-Jan-84 13:57:31 subroutine cpop include lspcm if( cptr <= 1 ) { call remark( "? Error in context stack." ) call toplv } else cptr = cptr - 1 return end #-t- cpop 144 ascii 15-Jan-84 13:57:31 #-h- cpush 205 ascii 15-Jan-84 13:57:31 subroutine cpush(i) include lspcm LISPVAL i if( cptr > CONTEXT_STACK_SIZE ) { call remark( "? Too many contexts on eval stack." ) call toplv } else { cstk(cptr) = i cptr = cptr + 1 } return end #-t- cpush 205 ascii 15-Jan-84 13:57:31 #-h- cr8fil 665 ascii 15-Jan-84 13:57:31 ### Cr8Fil Create a file for WRITE or APPEND access. LISPVAL function cr8fil() include lspcm character fil(FILENAMESIZE) filedes fd filedes create # function(s) integer stget # function(s) LISPVAL accmod, filnam LISPVAL mksbr, STRINGP # function(s) integer i filnam = areg # Get file spec. accmod = breg # Get access mode. ifdef( CHECK_ARGUMENTS ) if( STRINGP(filnam) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 i = stget( filnam, fil, i) if( accmod == QWRACC ) fd = create( fil, WRITE) else if( accmod == QAPACC ) fd = create( fil, APPEND ) else return(NIL) return( cons( QOCHANNEL, mksbr( fd))) end #-t- cr8fil 665 ascii 15-Jan-84 13:57:31 #-h- cwd 411 ascii 15-Jan-84 13:57:32 ### CWD Change working directory from within LISP. PREDICATE cwd() include lspcm integer i integer cwdir, stget # function(s) LISPVAL path LISPVAL STRINGP # function(s) path = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(path) != T ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 i = stget( path, strbuf, i) if( cwdir(strbuf) == OK ) return(T) else return(NIL) end #-t- cwd 411 ascii 15-Jan-84 13:57:32 #-h- defne 477 ascii 15-Jan-84 13:57:32 ### Defne Implements the "define" function. LISPVAL function defne() include lspcm LISPVAL arglst LISPVAL SYMBOLP # function(s) arglst = car(areg) defne = NIL while( arglst != NIL ) { ifdef( CHECK_ARGUMENTS ) if( SYMBOLP( car( car(arglst))) == NIL ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef call setvl( car( car(arglst)), car( cdr( car(arglst)))) defne = cons( car( car(arglst)), defne) arglst = cdr(arglst) } return end #-t- defne 477 ascii 15-Jan-84 13:57:32 #-h- defun 448 ascii 15-Jan-84 13:57:33 ### Defun Implements the "defun" function. LISPVAL function defun() include lspcm integer n LISPVAL argl LISPVAL PUTPROP, SYMBOLP # function(s) argl = areg areg = car(argl) breg = cons( QLAMBDA, cons( car( cdr(argl)), cons( car( cdr( cdr(argl))),NIL ))) creg = QVALUE ifdef( CHECK_ARGUMENTS ) if( SYMBOLP(areg) == NIL ) { call errlg( ARGUMENT_ERROR, ATOMIC_VALUE) return(QERROR) } enddef n = PUTPROP() return( car(argl)) end #-t- defun 448 ascii 15-Jan-84 13:57:33 #-h- depot 163 ascii 15-Jan-84 13:57:33 ### Depot Deposit into DATA_SPACE. subroutine depot( n, i) include lspcm include lspem LISPVAL i LISPVAL n LISPVAL adr adr = i lists(adr) = n return end #-t- depot 163 ascii 15-Jan-84 13:57:33 #-h- dfprp 457 ascii 15-Jan-84 13:57:33 ### Dfprp Implements "defprop". LISPVAL function dfprp() include lspcm LISPVAL n LISPVAL arglst, atm LISPVAL PUTPROP # function(s) arglst = areg areg = car(arglst) atm = areg breg = car( cdr(arglst)) creg = car( cdr( cdr(arglst))) n = PUTPROP() # Since the only difference between PUTPROP and DEFPROP is that DEFPROP # QUOTEs its arguments and returns the ATOM, it can just call PUTPROP. if( n == QERROR ) return(QERROR) else return(atm) end #-t- dfprp 457 ascii 15-Jan-84 13:57:33 #-h- diffr 331 ascii 15-Jan-84 13:57:34 LISPVAL function diffr() include lspcm LISPVAL i, j LISPVAL mknum, NUMBERP # function(s) real numvl i = areg j = breg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL | NUMBERP(j) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef ab = numvl(i) cd = numvl(j) ab = ab - cd return( mknum(ab)) end #-t- diffr 331 ascii 15-Jan-84 13:57:34 #-h- diml 535 ascii 15-Jan-84 13:57:34 LISPVAL function diml() include lspcm LISPVAL adescr, list LISPVAL mknum LISPVAL front, back, ele integer gtent integer aindex integer i, j adescr = areg if( car(adescr) != qarray ) call errlg(ARGUMENT_ERROR,ANYTHING) aindex = gtent(cdr(adescr)) front = cons(NIL,NIL) back = front PUSH(front) j = aindex + 1 for( i = 1 ; i <= arrays(aindex) ; i = i + 1 ) { ele = cons(mknum(float(arrays(j))),mknum(float(arrays(j+1)))) RPLACD(back,cons(ele,NIL)) back = cdr(back) j = j + 2 } front = POP return(cdr(front)) end #-t- diml 535 ascii 15-Jan-84 13:57:34 #-h- divd 472 ascii 15-Jan-84 13:57:35 ### Divd Implements "divide" (or "quotient"). LISPVAL function divd() include lspcm LISPVAL i, j LISPVAL mknum, NUMBERP # function(s) real numvl i = areg j = breg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL | NUMBERP(j) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef ab = numvl(i) cd = numvl(j) if( cd != 0.0 ) { ab = ab / cd return( mknum(ab)) } else { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } end #-t- divd 472 ascii 15-Jan-84 13:57:35 #-h- dmemb 449 ascii 15-Jan-84 13:57:35 LISPVAL function dmemb() include lspcm LISPVAL ele, lst, val LISPVAL atom, jcall # function(s) ENTRY_POINT ele = areg lst = breg if( ele == lst ) RETURN_VALUE(T) else if( atom(lst) == NIL ) { PUSH(ele) PUSH(lst) areg = ele breg = car(lst) val = jcall(dmembf) lst = POP ele = POP if( val != NIL ) RETURN_VALUE(val) areg = ele breg = cdr(lst) val = jcall(dmembf) RETURN_VALUE(val) } else RETURN_VALUE(NIL) end #-t- dmemb 449 ascii 15-Jan-84 13:57:35 #-h- dospwn 704 ascii 15-Jan-84 13:57:35 ### DoSpwn Spawn a process from within LISP. PREDICATE dospwn() include lspcm character args(ARGBUFSIZE), desc(PIDSIZE), proces(FILENAMESIZE) character cmdstr(FILENAMESIZE) character chget # function(s) integer cmdlen, i integer loccom, spawn, strln # function(s) LISPVAL cmd string suffix IMAGE_SUFFIX cmd = areg cmdlen = strln(cmd) for( i = 1 ; i <= cmdlen ; i = i + 1 ) { cmdstr(i) = chget( cmd, i) if( cmdstr(i) == BLANK | cmdstr(i) == TAB ) break } cmdstr(i) = EOS call impath(args) # get search path if( loccom( cmdstr, args, suffix, proces) != BINARY ) return(NIL) i = 1 call stget( cmd, args, i) if( spawn( proces, args, desc, WAIT) == OK ) return(T) else return(NIL) end #-t- dospwn 704 ascii 15-Jan-84 13:57:35 #-h- dotpt 854 ascii 15-Jan-84 13:57:36 ### DotPt Print list in DOT notation. LISPVAL function dotpt() include lspcm LISPVAL iadr, iptr, i2 LISPVAL jcall LISPVAL STRINGP, atom LISPVAL patom ENTRY_POINT iadr = areg iptr = iadr dotpt = NIL if( atom(iadr) == T ) # Check for atoms. { # If it is an ATOM print it. iadr = patom(iadr) dotpt = iadr RETURN_VALUE(iadr) } # If the item is a DOTed pair, print it recursively. else if( atom(iadr) == NIL ) { PRINTCH('(') PUSH(iadr) PUSH(iptr) areg = car(iptr) i2 = jcall(dotptf) iptr = POP iadr = POP PRINTCH(' ') PRINTCH('.') PRINTCH(' ') PUSH(iadr) PUSH(iptr) areg = cdr(iptr) i2 = jcall(dotptf) iptr = POP iadr = POP PRINTCH(')') } else call perr # This include a verification of the interpreter. # every object should either be an atom or not an # atom. dotpt = iadr RETURN_VALUE(iadr) end #-t- dotpt 854 ascii 15-Jan-84 13:57:36 #-h- emait 757 ascii 15-Jan-84 13:57:36 subroutine emait # The subroutine EMAIT initializes the data base. include lspcm include lspem integer i lptr = FIRST_NODE nodect = 0 stptr = 1 ifnotdef( VAX_VMS ) # Avoid the overhead of zero-filling, if possible. for( i = 1 ; i <= DATA_SPACE ; i = i + 1 ) lists(i) = 0 for( i = 1 ; i <= OBLIST_LENGTH ; i = i + 1 ) oblist(i) = NIL enddef for( i = FIRST_NODE ; i <= LAST_NODE - 3 ; i = i + 3 ) { AUX_FIELD(i) = FREE_BIT CAR_FIELD(i) = i + 3 nodect = nodect + 1 } CAR_FIELD(i) = NIL av = 1 arrays(1) = 1 arrays(2) = 0 arrays(3) = 7 arrays(4) = 7 arrays(5) = 1 arrays(6) = 1 arrays(7) = 0 arrays(8) = ARRAY_SPACE - 7 arrays(9) = 1 arrays(10) = 1 arrays( ARRAY_SPACE - 2 ) = 7 arrays( ARRAY_SPACE - 1 ) = 0 arrays(ARRAY_SPACE) = 1 return end #-t- emait 757 ascii 15-Jan-84 13:57:36 #-h- entir 405 ascii 15-Jan-84 13:57:37 LISPVAL function entir() include lspcm LISPVAL i LISPVAL mknum, NUMBERP # function(s) integer iflr real numvl, x i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef x = numvl(i) if( ifix(x) == x ) return(i) else if( x > 0.0 ) return( mknum( float( ifix(x)))) else return( mknum( float( ifix( x - 1.0 )))) end #-t- entir 405 ascii 15-Jan-84 13:57:37 #-h- eq 588 ascii 15-Jan-84 13:57:37 ### EQ Test for equality of ATOMs. ### In this LISP SYMBOLs, STRINGs & NUMBERs are all ATOMs. PREDICATE eq( i, j) include lspcm integer ians, stcom real numvl, x LISPVAL i, j LISPVAL atom, NUMBERP, STRINGP, SYMBOLP # function(s) eq = NIL if( i == j & (j == NIL | j == T)) eq = T else if( SYMBOLP(i) == T & SYMBOLP(j) == T ) { if( i == j ) eq = T } else if( STRINGP(i) == T & STRINGP(j) == T ) { ians = stcom( i, j) if( ians == 0 ) eq = T } else if( NUMBERP(i) == T & NUMBERP(j) == T ) { ab = numvl(i) cd = numvl(j) if( ab == cd ) eq = T } return end #-t- eq 588 ascii 15-Jan-84 13:57:37 #-h- eq2 109 ascii 15-Jan-84 13:57:38 LISPVAL function eq2() include lspcm LISPVAL eq LISPVAL i, j i = areg j = breg return( eq( i, j)) end #-t- eq2 109 ascii 15-Jan-84 13:57:38 #-h- equal2 621 ascii 15-Jan-84 13:57:38 ### Equal Tests for equality of arbitrary LISP values. PREDICATE equal2() include lspcm LISPVAL arg1, arg2, first, scnd LISPVAL atom, eq, jcall # function(s) ENTRY_POINT arg1 = areg arg2 = breg equal2 = NIL if( atom(arg1) == T ) RETURN_VALUE( eq( arg1, arg2)) else { PUSH(arg1) PUSH(arg2) areg = car(arg1) breg = car(arg2) first = jcall(equalf) arg2 = POP arg1 = POP if( first == T ) { PUSH(arg1) PUSH(arg2) areg = cdr(arg1) breg = cdr(arg2) scnd = jcall(equalf) arg2 = POP arg1 = POP RETURN_VALUE(scnd) } else RETURN_VALUE(NIL) } RETURN_VALUE(NIL) end #-t- equal2 621 ascii 15-Jan-84 13:57:38 #-h- errlg 1831 ascii 15-Jan-84 13:57:38 ### ErrLg Log error messages. subroutine errlg( i, j) # This subroutine takes two parameters and prints out two messages # according to the parameters. The first parameter is the index of # the error that occurred and the second is the index of the # helpful advice that goes with the error. The helpful advice is # usually just what the function returning the error would have # returned on a normal return. include lspcm integer i, j switch(i) { case ARITH_ERROR: call remark( "? Arithmetic error.") case STRING_ERROR: call remark( "? String error.") case INCOMP_ERROR: call remark( "? Incompatable data types.") case ARRAY_SPEC_ERROR: call remark( "? Array specification error.") case ARRAY_SPACE_ERROR: call remark( "? Insufficient array space.") case SUBSCRIPT_ERROR: call remark( "? Subscript error.") case SEVERE_ERROR: call remark( "? Critical error -- oops!.") case UNBOUND_ERROR: call remark( "? Unbound variable.") case CANT_EVAL_ERROR: call remark( "? Object not defined by eval.") case IO_ERROR: call remark( "? I/O error.") case NOPROG_ERROR: call remark( "? No PROG in context.") case LIST_ERROR: call remark( "? List structure error.") case ARGUMENT_ERROR: call remark( "? Illegal arguments to function.") default: call remark( "? Undefined error.") } switch(j) { case NUMERIC_VALUE: call remark( "Provide a numeric value." ) case STRING_VALUE: call remark( "Provide a string value." ) case TRUTH_VALUE: call remark( "Provide T or NIL." ) case FUNCTION_VALUE: call remark( "Provide a functional value." ) case ANYTHING: call remark( "Provide any S-expression." ) case RESTART_LISP: call remark( "(toplevel) is suggested." ) case ATOMIC_VALUE: call remark( "Provide an atomic value." ) default: call remark( "DO SOMETHING!!!." ) } return end #-t- errlg 1831 ascii 15-Jan-84 13:57:38 #-h- eshell 718 ascii 15-Jan-84 13:57:39 ### EShell Execute a Shell command from within LISP. PREDICATE eshell() include lspcm character args(ARGBUFSIZE), desc(PIDSIZE), proces(FILENAMESIZE) integer cmdlen, i, init, j integer loccom, spawn, strln # function(s) LISPVAL cmd string dashc " -c " string sh "esh" string suffix IMAGE_SUFFIX data init / YES / if( init == YES ) { call impath(args) # get search path if( loccom( sh, args, suffix, proces) != BINARY ) return(NIL) j = 1 call stcopy( sh, 1, args, j) init = NO } cmd = areg cmdlen = strln(cmd) i = j if( cmdlen > 0 ) { call stcopy( dashc, 1, args, i) call stget( cmd, args, i) } args(i) = EOS if( spawn( proces, args, desc, WAIT) == OK ) return(T) else return(NIL) end #-t- eshell 718 ascii 15-Jan-84 13:57:39 #-h- eval 8040 ascii 15-Jan-84 13:57:39 ### Eval Evaluate LISP objects. LISPVAL function eval() # EVAL knows about ATOMs, SUBRs, FSUBRs, LSUBRs, ARRAYs, LAMBDAs, # LABELs, CHANNELs and MACROs. # # For ATOMs SYMBOLs EVALuate to their values, and # every thing else EVALuates to itself. # # For SUBRs,the arguments are EVALuated and placed in a common # area from which the function can retrieve them. The function # entry point is then called. # # For FSUBRs the argument list is passed unEVALuated in the # register common and the function is called indirectly. # # For LSUBRs the argument list is EVALuated and then passed as # a list, not individual arguments. # # LAMBDAs are handled by binding the arguments of the call # to the formal parameters of the LAMBDA and then EVALuating the # body of the LAMBDA. # # ARRAY references are handled by the array package. # # MACROs are evaluated by binding the calling form (not just the # argument list) to the formal parameter list. The result of the # MACRO is the evaluated. include lspcm LISPVAL jcall # Indirect function call LISPVAL j LISPVAL brkp LISPVAL ifbrk LISPVAL func # The CAR of the form being evaluated LISPVAL val # The value being returned LISPVAL arglst # The CDR of the form being evaluated LISPVAL ircr # Recursion call LISPVAL varlst # Argument list LISPVAL idef, fdef # LAMBDA form for a function LISPVAL form # the form to pass to the MACRO LISPVAL getvl # Function to get the value of an atom LISPVAL list, acces LISPVAL type # Gets the type of the function ADDRESS ientry ADDRESS gtent # Function to get the value of a SUBR LISPVAL ifs, kk # Function definitions for compiled functions LISPVAL get # Get function integer iseg # Segment number for a function integer i, k real numvl integer reg(5) equivalence ( areg, reg(1)) LISPVAL atom, SYMBOLP, STRINGP, NUMBERP ENTRY_POINT eval = 0 func = areg #i = jcall(printf) #TERPRI # The context (the current form) is saved as a debugging aid. PUSH_CONTEXT(func) # Check for an operator BReak #if( ifbrk()) #{ # PUSH(func) # val=brkp() # func=POP #} # EVALuate ATOMs if( atom(func) == T ) { if( func == NIL ) { POP_CONTEXT RETURN_VALUE(NIL) } else if( func == T ) { POP_CONTEXT RETURN_VALUE(T) } else if( SYMBOLP(func) == T ) { val = getvl(func) # Here is the first example of error handling in EVAL. # All the other routines in the interpreter merely # pass back an error value to EVAL, and let EVAL take # care of it. if( val == QUNBOUND ) { # Print the offending TERPRI variable. LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = func i = jcall(printf) TERPRI call errlg( UNBOUND_ERROR, ANYTHING) # Print the message. val = brkp() POP_CONTEXT RETURN_VALUE(val) } # Otherwise return the value of the variable. POP_CONTEXT RETURN_VALUE(val) } else if( STRINGP(func) == T ) { POP_CONTEXT RETURN_VALUE(func) } else if( NUMBERP(func) == T ) { POP_CONTEXT RETURN_VALUE(func) } else # Some sort of atom (like an entrypoint) that we can't EVALuate. { LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = func i = jcall(printf) TERPRI call errlg( CANT_EVAL_ERROR, ATOMIC_VALUE) val = brkp() POP_CONTEXT RETURN_VALUE(val) } } # If the CAR is not a function reference try to EVALuate it to an one. type = car( car(func)) # Here we see all the valid types of function reference if( type != QLAMBDA & type != qarray & type != qsubr & type != QFSUBR & type != qlabel & type != qlsubr & type != QICHANNEL & type != QOCHANNEL & type != qmacro) { PUSH(func) areg = car(func) func = jcall(evalf) form = POP # We need to save the form for the MACROs arglst = cdr(form) type = car(func) } else # If the type was recognized, remove the func reference and the arg. list. { form = func # Save that forms for the MACROs arglst = cdr(func) func = car(func) } repeat # Not really, just a construct we can "break" from on error. { if( type == qsubr ) # SUBR { kk = cdr(func) # EVALuate the arguments and put them in the register common. for( i = 1 ; i <= MAX_SUBR_ARGS ; i = i + 1 ) reg(i) = NIL for( i = 1 ; i <= MAX_SUBR_ARGS & arglst != NIL ; i = i + 1 ) { PUSH_REGISTERS PUSH(kk) PUSH(i) PUSH(arglst) areg = car(arglst) k = jcall(evalf) arglst = POP i = POP kk = POP POP_REGISTERS reg(i) = k arglst = cdr(arglst) } if( atom(kk) == NIL ) { iseg = gtent( car(kk)) ientry = gtent( cdr(kk)) LOAD_SEGMENT_IF_NECESSARY( iseg ) } else ientry = gtent(kk) val = jcall(ientry) if( val == QERROR ) break POP_CONTEXT RETURN_VALUE(val) } else if( type == QFSUBR ) # FSUBR { ifs = cdr(func) if( atom(ifs) == NIL ) { iseg = gtent( car(ifs)) ientry = gtent( cdr(ifs)) LOAD_SEGMENT_IF_NECESSARY( iseg ) } else ientry = gtent(ifs) areg = arglst val = jcall(ientry) if( val == QERROR ) break POP_CONTEXT RETURN_VALUE(val) } else if( type == qlsubr ) # LSUBR { ifs = cdr(func) PUSH(ifs) areg = arglst arglst = list() ifs = POP if( atom(ifs) == NIL ) { iseg = gtent( car(ifs)) ientry = gtent( cdr(ifs)) LOAD_SEGMENT_IF_NECESSARY( iseg ) } else ientry = gtent(ifs) areg = arglst val = jcall(ientry) if( val == QERROR ) break POP_CONTEXT RETURN_VALUE(val) } else if( type == QLAMBDA ) # LAMBDA { idef = func varlst = car( cdr(idef)) PUSH(idef) PUSH(varlst) areg = varlst breg = arglst call bind varlst = POP idef = POP PUSH(varlst) idef = cdr( cdr(idef)) while(idef != NIL) { PUSH(idef) areg = car(idef) val = jcall(evalf) idef = cdr(POP) } varlst = POP areg = varlst call UNBIND POP_CONTEXT RETURN_VALUE(val) } else if( type == qlabel ) # LABEL { idef = car( cdr( cdr(func))) func = car( cdr(func)) areg = func breg = idef call bind PUSH(func) areg = cons( func, arglst) val = jcall(evalf) func = POP areg = func call UNBIND POP_CONTEXT RETURN_VALUE(val) } else if( type == qarray ) # ARRAY { PUSH(func) areg = arglst arglst = list() func = POP areg = func breg = arglst val = acces() if( val == QERROR ) break POP_CONTEXT RETURN_VALUE(val) } else if( type == QICHANNEL ) # ICHANNEL { j = inpstk(inplvl) inpstk(inplvl) = gtent( cdr(func)) LOAD_SEGMENT_IF_NECESSARY( READSEG ) val = jcall(readfn) inpstk(inplvl) = j if( val == QERROR ) break POP_CONTEXT RETURN_VALUE(val) } else if( type == QOCHANNEL ) # OCHANNEL { j = output output = gtent( cdr(func)) while( arglst != NIL ) { PUSH(func) PUSH(arglst) PUSH(j) areg = car(arglst) val = jcall(evalf) j = POP arglst = POP func = POP LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = val val = jcall(printf) arglst = cdr(arglst) } TERPRI output = j POP_CONTEXT RETURN_VALUE(val) } else if( type == qmacro ) # MACRO { idef = func varlst = car(cdr(idef)) PUSH(idef) PUSH(varlst) PUSH(form) areg = varlst breg = form call bind form = POP varlst = POP idef = POP PUSH(form) PUSH(varlst) areg = car( cdr( cdr(idef))) val = jcall(evalf) varlst = POP areg = varlst call UNBIND areg = val val = jcall(evalf) form = POP POP_CONTEXT RETURN_VALUE(val) } else { call errlg( CANT_EVAL_ERROR, ANYTHING) LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = func i = jcall(printf) TERPRI val = brkp() POP_CONTEXT RETURN_VALUE(val) } } val = brkp() POP_CONTEXT RETURN_VALUE(val) end #-t- eval 8040 ascii 15-Jan-84 13:57:39 #-h- evenp 423 ascii 15-Jan-84 13:57:41 ### EvenP Determine whether or not the argument is even. PREDICATE evenp() include lspcm LISPVAL i LISPVAL NUMBERP # function(s) real x real numvl # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, TRUTH_VALUE) return(QERROR) } enddef x = numvl(i) if( float( ifix(x)) != x ) return(NIL) else if( amod( x, 2.0 ) == 0.0 ) return(T) else return(NIL) end #-t- evenp 423 ascii 15-Jan-84 13:57:41 #-h- exame 158 ascii 15-Jan-84 13:57:41 ### Exame Examine a cell in DATA_SPACE. LISPVAL function exame(i) include lspcm include lspem LISPVAL i LISPVAL adr adr = i return( lists(adr)) end #-t- exame 158 ascii 15-Jan-84 13:57:41 #-h- expld 526 ascii 15-Jan-84 13:57:41 ### Explode Explode a string into a list of atoms. LISPVAL function expld() include lspcm character s(2) character chget # function(s) integer i, ilen integer strln # function(s) LISPVAL iarg LISPVAL INTERN, STRINGP # function(s) iarg = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(iarg) == NIL ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef ilen = strln(iarg) expld = NIL for( i = ilen ; i >= 1 ; i = i - 1 ) { PUSH(expld) s(1) = chget( iarg, i) expld = cons( INTERN(s), POP) } return end #-t- expld 526 ascii 15-Jan-84 13:57:41 #-h- expt 713 ascii 15-Jan-84 13:57:42 ### Expt Perform x^y. LISPVAL function expt() include lspcm integer iy LISPVAL i, j LISPVAL mknum, NUMBERP # function(s) real x, y real numvl # function(s) i = areg j = breg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL | NUMBERP(j) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef x = numvl(i) y = numvl(j) repeat # Provide a contruct from which to break on error. { if( x == 0.0 & y <= 0.0 ) break if( float( ifix(x)) != x & x < 0.0 ) { if( float( ifix(y)) != y ) break else { iy = ifix(y) return( mknum( x ** iy )) } } else return( mknum( x ** y )) } call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) end #-t- expt 713 ascii 15-Jan-84 13:57:42 #-h- expx 310 ascii 15-Jan-84 13:57:42 ### Expx Return e^x. LISPVAL function expx() include lspcm LISPVAL i LISPVAL mknum, NUMBERP # function(s) real numvl, exp # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( exp( numvl(i)))) end #-t- expx 310 ascii 15-Jan-84 13:57:42 #-h- extfn 58 ascii 15-Jan-84 13:57:43 LISPVAL function extfn() extfn = NIL call endst(OK) end #-t- extfn 58 ascii 15-Jan-84 13:57:43 #-h- fix 294 ascii 15-Jan-84 13:57:43 LISPVAL function fix() include lspcm LISPVAL i LISPVAL mknum, NUMBERP # function(s) real numvl # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( float( ifix( numvl(i))))) end #-t- fix 294 ascii 15-Jan-84 13:57:43 #-h- fixp 361 ascii 15-Jan-84 13:57:43 ### FixP Predicate for integers < MAX_INTEGER. PREDICATE fixp() include lspcm LISPVAL i LISPVAL NUMBERP # function(s) real x real numvl # function(s) i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, TRUTH_VALUE) return(QERROR) } enddef x = numvl(i) if( float( ifix(x)) != x ) return(NIL) else return(T) end #-t- fixp 361 ascii 15-Jan-84 13:57:43 #-h- flags 508 ascii 15-Jan-84 13:57:44 ### Flags Process command-line flags for LISP subroutine flags( argbuf, bufsiz) include cflag character argbuf(ARB) character clower # function(s) integer bufsiz, i integer getarg # function(s) for( i = 1 ; getarg( i, argbuf, bufsiz) != EOF ; i = i + 1 ) { if( argbuf(1) == '-' ) { c = clower( argbuf(2)) switch( c ) { case 'b': bare = YES case 'q': quiet = YES case 'v': verbos = YES } call delarg(i) i = i - 1 } } return end #-t- flags 508 ascii 15-Jan-84 13:57:44 #-h- fldstr 384 ascii 15-Jan-84 13:57:44 ### FldStr Fold a string to lowercase. LISPVAL function fldstr() include lspcm integer i, len LISPVAL str LISPVAL MAKSTRING, stget, STRINGP # function(s) str = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(str) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 len = stget( str, strbuf, i) call fold(strbuf) return( MAKSTRING( strbuf)) end #-t- fldstr 384 ascii 15-Jan-84 13:57:44 #-h- floop 786 ascii 15-Jan-84 13:57:45 ### FLoop Inplement the "for" loop construct. LISPVAL function floop() include lspcm LISPVAL val, eval, arglst LISPVAL cond, rept, ncond, sevl LISPVAL i, n ENTRY_POINT floop = NIL arglst = areg PUSH(arglst) areg = car(arglst) # EVALuate init n = eval() arglst = cdr(POP) cond = car(arglst) rept = car( cdr(arglst)) arglst = cdr( cdr(arglst)) PUSH(arglst) PUSH(cond) PUSH(rept) areg = cond ncond = eval() # NCOND is the value of cond rept = POP cond = POP arglst = POP while( ncond != NIL ) { PUSH(arglst) PUSH(cond) PUSH(rept) areg = arglst val = sevl() # This uses SEVL like COND areg = POP PUSH(areg) i = eval() rept = POP areg = POP PUSH(areg) PUSH(rept) ncond = eval() rept = POP cond = POP arglst = POP } floop = val RETURN_VALUE(val) end #-t- floop 786 ascii 15-Jan-84 13:57:45 #-h- flshp 277 ascii 15-Jan-84 13:57:45 ### FlshP Flush the print buffer. LISPVAL function flshp() include lspcm flshp = NIL if( pcptr != 0 ) { prbuf( pcptr + 1 ) = EOS call stmode( output, RARE) call putch( LF, output) call putlin( prbuf, output) call stmode( output, COOKED) pcptr = 0 } return end #-t- flshp 277 ascii 15-Jan-84 13:57:45 #-h- flshr 104 ascii 15-Jan-84 13:57:45 ### FlshR Flush the read buffer. LISPVAL function flshr() include lspcm icptr = 0 return(NIL) end #-t- flshr 104 ascii 15-Jan-84 13:57:45 #-h- fnctn 541 ascii 15-Jan-84 13:57:46 ### Fnctn Implement "function". ### If "fnctn" is passed a function or an atom which ### EVALuates to a function, it returns the function. ### Otherwise it acts just like QUOTE. LISPVAL function fnctn() include lspcm LISPVAL arglst LISPVAL getvl LISPVAL def, type LISPVAL atom arglst = areg def = getvl( car(arglst)) type = NIL if( atom(def) == NIL ) type = car(def) if( type == QLAMBDA | type == qsubr | type == QFSUBR | type == qlabel | type == qarray | type == qlsubr ) return(def) else return( car(arglst)) end #-t- fnctn 541 ascii 15-Jan-84 13:57:46 #-h- free 1542 ascii 15-Jan-84 13:57:46 subroutine free(k) # The FREE routine takes a block and puts it back on the available # storage list. Adjacent blocks are compacted, if possible. include lspcm include lspem integer n, p, q, k p = k - 2 # The user was returned a pointer past the overhead words n = arrays( p + 1 ) # If both left & right blocks are in use... if( arrays( p - 1 ) == 1 & arrays( p + n ) == 1 ) { arrays(p) = 0 arrays( p + n - 1 ) = 0 arrays( p + n - 2 ) = p arrays( p + 2 ) = av arrays( p + 3 ) = arrays( av + 3 ) arrays( arrays( p + 3 ) + 2 ) = p arrays( av + 3 ) = p } # If the left block is free... else if( (arrays( p + n ) == 1 | p + n == ARRAY_SPACE) & arrays( p - 1 ) == 0 ) { q = arrays( p - 2 ) arrays( q + 1 ) = arrays( q + 1 ) + n arrays( p + n - 2 ) = q ; arrays( p + n - 1 ) = 0 } # If the right block is free... else if( arrays( p + n ) == 0 & arrays( p - 1 ) == 1 & p + n != ARRAY_SPACE ) { arrays( arrays( p + n + 2 ) + 3 ) = p arrays( arrays( p + n + 3 ) + 2 ) = p arrays( p + 2 ) = arrays( p + n + 2 ) arrays( p + 3 ) = arrays( p + n + 3 ) arrays( p + 1 ) = n + arrays( p + n + 1 ) arrays( p + arrays( p + 1 ) - 2 ) = p arrays(p) = 0 if( av == p + n ) av = p } else # If they are both free. { arrays( arrays( p + n + 2 ) + 3 ) = arrays( p + n + 3 ) arrays( arrays( p + n + 3 ) + 2 ) = arrays( p + n + 2 ) q = arrays( p - 2 ) arrays( q + 1 ) = arrays( q + 1 ) + n + arrays( p + n + 1 ) arrays( q + arrays( q + 1 ) - 2 ) = q if( av == p + n ) av = arrays( p + n + 2 ) } return end #-t- free 1542 ascii 15-Jan-84 13:57:46 #-h- gc 2148 ascii 15-Jan-84 13:57:47 ### GC The Garbage Collector. PREDICATE gc() # This function is called by the storage allocator HEAP when there are no # more nodes. It is also invokable by the user as "gc". include lspcm include lspem integer clrwrd, datst, i, iend, istart, n, ndim, p LISPVAL lst LISPVAL comp # function(s) gc = NIL # Two bits of the aux field are used by the garbage collector, # the TAG_BIT and the MARK_BIT. # # Clear the MARK bit on all nodes and set the TAG bit on all conses. clrwrd = iand( not(TAG_BIT), not(MARK_BIT)) for( i = INUM + 1 ; i <= DATA_SPACE ; i = i + 3 ) { lists(i) = iand( lists(i), clrwrd) if( iand( lists(i), ATOM_HEADER) == 0 ) lists(i) = ior( lists(i), TAG_BIT) } # Here we see all the places that the garbage collector has to look. # The OBLIST for( i = 1 ; i <= OBLIST_LENGTH ; i = i + 1 ) { lst = oblist(i) if( lst == NIL ) next call mark1(lst) while( lst != NIL ) { call mark1( cdr( car( car(lst)))) lst = cdr(lst) } } # The DATA STACK for( i = 1 ; i <= dsp ; i = i + 1 ) call mark1( dstack(i)) # The CONTEXT STACK for( i = 1 ; i <= cptr - 1 ; i = i + 1 ) call mark1( cstk(i)) # The last few nodes allocated from the heap (just in case). for( i = 0 ; i <= QUEUE_LENGTH ; i = i + 1 ) call mark1( cqueue(i)) # All the nodes reachable from the arrays. p = 7 repeat { n = arrays( p + 1 ) if( arrays(p) != 1 ) p = p + n else { ndim = arrays( p + 2 ) istart = p + 3 + ndim * 2 iend = p + n - 2 for( i = istart ; i <= iend ; i = i + 1 ) call mark1( ( arrays(i))) p = p + n } } until( p == ARRAY_SPACE ) if( press == YES ) # Compress the data space. gc = comp() else { lptr = NIL nodect = 0 clrwrd = iand( not(TAG_BIT), not(MARK_BIT)) for( EVERY_NODE(i) ) { if( NODE_IS_NOT_MARKED(i) ) { CAR_FIELD(i) = lptr AUX_FIELD(i) = FREE_BIT lptr = i nodect = nodect + 1 } else AUX_FIELD(i) = iand( AUX_FIELD(i), clrwrd) } } # GC returns NIL if there are no nodes left. It does not check to # see if it actually increased the nodecount. if( nodect == 0 ) return(NIL) else return(T) end #-t- gc 2148 ascii 15-Jan-84 13:57:47 #-h- gcs 2043 ascii 15-Jan-84 13:57:47 ### GCS Garbage-collect the string space. PREDICATE gcs() # This routine marks all the string nodes which are in use and # then allocates a piece of array space to put the list of nodes in. # This list is then heap sorted. The string space is then compacted. include lspcm include cgcs integer i, j integer strcnt integer nexts integer lstch, plstch, fstch integer nxtnd, fstnd integer delta LISPVAL STRINGP string errmsg "? Not enough space to collect strings." for( EVERY_NODE(i) ) if( iand( AUX_FIELD(i), ior( ATOM_HEADER, FREE_BIT)) == 0 ) { if( STRINGP( car(i)) == T ) MARK_NODE( car(i)) if( STRINGP( cdr(i)) == T ) MARK_NODE( cdr(i)) } strcnt = 0 for( EVERY_NODE(i) ) if( NODE_IS_MARKED(i) ) strcnt = strcnt + 1 call allct( strcnt * NODE_SIZE, base) if( base == NIL ) call error(errmsg) nexts = 1 for( EVERY_NODE(i) ) if( NODE_IS_MARKED(i) ) { STRING_START(nexts) = cdr(i) STRING_LENGTH(nexts) = car(i) NODE_ADDRESS(nexts) = i UNMARK_NODE(i) nexts = nexts + 1 } call hsort(strcnt) lstch = 0 nxtnd = 1 while( lstch+1 >= STRING_START(nxtnd) & nxtnd <= strcnt ) { if( STRING_START(nxtnd) + STRING_LENGTH(nxtnd) - 1 > lstch ) lstch = STRING_START(nxtnd) + STRING_LENGTH(nxtnd) - 1 nxtnd = nxtnd + 1 } if(nxtnd > strcnt) { call free(base) return(NIL) } plstch = lstch repeat { fstch = STRING_START(nxtnd) lstch = STRING_START(nxtnd) + STRING_LENGTH(nxtnd) - 1 fstnd = nxtnd nxtnd = nxtnd + 1 while( lstch+1 >= STRING_START(nxtnd) & nxtnd <= strcnt ) { if( STRING_START(nxtnd) + STRING_LENGTH(nxtnd) - 1 > lstch ) lstch = STRING_START(nxtnd) + STRING_LENGTH(nxtnd) - 1 nxtnd = nxtnd + 1 } delta = fstch - plstch - 1 for( i = fstch ; i <= lstch ; i = i + 1 ) strngs( i - delta ) = strngs(i) for( i = fstnd ; i <= nxtnd - 1 ; i = i + 1 ) CDR_FIELD( NODE_ADDRESS(i)) = CDR_FIELD( NODE_ADDRESS(i)) - delta plstch = lstch - delta } until( nxtnd > strcnt ) stptr = plstch call free(base) return(T) end #-t- gcs 2043 ascii 15-Jan-84 13:57:47 #-h- gensm 335 ascii 15-Jan-84 13:57:48 ### GenSym Return the next symbol in a sequence of gxxxxx. LISPVAL function gensm() include lspcm character buf(20) LISPVAL INTERN character ch integer i call cnumo( symcnt, buf) for( i = 1 ; i <= 6 ; i = i + 1 ) { if( buf(i) == ' ' ) buf(i) = '0' } buf(1) = 'g' buf(7) = EOS symcnt = symcnt + 1 return( INTERN(buf)) end #-t- gensm 335 ascii 15-Jan-84 13:57:48 #-h- get 577 ascii 15-Jan-84 13:57:48 ### Get Return the value under the PROPERTY specified, or NIL. LISPVAL function get() include lspcm LISPVAL plst, prp, atm LISPVAL rtn # Value to return if the property is not found. LISPVAL SYMBOLP atm = areg prp = breg rtn = creg ifdef( CHECK_ARGUMENTS ) if( SYMBOLP(atm) == NIL | SYMBOLP(prp) == NIL ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef if( prp == QVALUE ) return( car(atm)) plst = cdr(atm) while( plst != NIL & car(plst) != prp ) plst = cdr( cdr(plst)) if( plst == NIL ) return(rtn) else return( car( cdr(plst))) end #-t- get 577 ascii 15-Jan-84 13:57:48 #-h- getln 543 ascii 15-Jan-84 13:57:49 ### GetLn Get a line from specified channel and convert to LISP string. LISPVAL function getln() include lspcm filedes fd filedes gtent # function(s) integer len integer getlin # function(s) LISPVAL chn LISPVAL MAKSTRING # function(s) chn = areg ifdef( CHECK_ARGUMENTS ) if( chn != NIL & car(chn) != QICHANNEL ) { call errlg( IO_ERROR, RESTART_LISP) return(QERROR) } enddef if( chn == NIL ) fd = STDIN else fd = gtent( cdr( chn)) len = getlin( strbuf, fd) if( len == EOF ) return(NIL) return( MAKSTRING( strbuf)) end #-t- getln 543 ascii 15-Jan-84 13:57:49 #-h- getvl 149 ascii 15-Jan-84 13:57:49 ### GetVl Get a symbol's current value from the CAR of the atom header. LISPVAL function getvl(i) include lspcm LISPVAL i return( car(i)) end #-t- getvl 149 ascii 15-Jan-84 13:57:49 #-h- go 490 ascii 15-Jan-84 13:57:49 ### Go Implements the "go" function. LISPVAL function go() # This function is more complicated than RETURN because it is an FSUBR # and we allow it to EVALuate its arguments in order to get a label. include lspcm LISPVAL form LISPVAL eval LISPVAL atom external prog ENTRY_POINT form = areg go = NIL form = car(form) while( atom(form) == NIL ) # Keep EVALuating it until we get an ATOM. { areg = form form = eval() } gval = form call jctxt call jmp( prog, glabl, progsp) end #-t- go 490 ascii 15-Jan-84 13:57:49 #-h- grtp 488 ascii 15-Jan-84 13:57:50 ### GrtP "Greater" predicate for numbers and strings. PREDICATE grtp() include lspcm LISPVAL val, i, j integer jlen, ilen, k integer strln, stcom real numvl LISPVAL NUMBERP, STRINGP i = areg j = breg if( NUMBERP(i) == T & NUMBERP(j) == T ) { ab = numvl(i) cd = numvl(j) if( ab > cd ) grtp = T else grtp = NIL } else if( STRINGP(i) == T & STRINGP(j) == T ) { val = stcom( i, j) if( val > 0 ) grtp = T else grtp = NIL } else grtp = NIL return end #-t- grtp 488 ascii 15-Jan-84 13:57:50 #-h- gtent 139 ascii 15-Jan-84 13:57:50 ### GtEnt Get the address of a SUBR's entry point. LISPVAL function gtent(atm) include lspcm LISPVAL atm return( EXAMINE(atm)) end #-t- gtent 139 ascii 15-Jan-84 13:57:50 #-h- hash 290 ascii 15-Jan-84 13:57:51 ### Hash Generate a hash key into the OBLIST. integer function hash(buf) include lspcm character buf(ARB) integer i, j integer length # function(s) i = buf(1) - ' ' if( length(buf) > 1 ) j = 1 else j = 0 hash = 2 * i + j if( hash < 1 | hash > oblen ) hash = oblen return end #-t- hash 290 ascii 15-Jan-84 13:57:51 #-h- heap 542 ascii 15-Jan-84 13:57:51 ### Heap Allocate a cons from DATA_SPACE and return its ADDRESS. ADDRESS function heap() include lspcm include lspem LISPVAL rslt LISPVAL gc if( lptr == NIL ) { rslt = gc() if( rslt == NIL ) call error( "? Heap overflow." ) } heap = lptr # Return the address of the CAR AUX_FIELD(heap) = 0 lptr = CAR_FIELD(lptr) nodect = nodect - 1 # We are keeping a circular queue of the most recently allocated nodes # for the garbage collector. cqueue(nxtele) = heap nxtele = nxtele + 1 nxtele = iand( nxtele, QUEUE_LENGTH) return end #-t- heap 542 ascii 15-Jan-84 13:57:51 #-h- hsort 483 ascii 15-Jan-84 13:57:51 ### HSort Heap-sort the list of string nodes. subroutine hsort(n) define(SWAP_VARIABLES, { temp = $1 $1 = $2 $2 = temp }) define(SWAP, { SWAP_VARIABLES(STRING_START($1),STRING_START($2)) SWAP_VARIABLES(STRING_LENGTH($1),STRING_LENGTH($2)) SWAP_VARIABLES(NODE_ADDRESS($1),NODE_ADDRESS($2)) }) include lspcm include cgcs integer n integer i, temp do i = n / 2, 1, -1 call adjust( i, n) do i = n - 1, 1, -1 { SWAP( i + 1, 1) call adjust( 1, i) } return end #-t- hsort 483 ascii 15-Jan-84 13:57:51 #-h- ieqst 577 ascii 15-Jan-84 13:57:52 ### IEqSt Test 2 string ranges for equality. integer function ieqst( jstr, jbeg, jend, kstr, kbeg, kend) define( wildch, 10) character c1, c2 character jstr(ARB), kstr(ARB) integer jbeg, jend, kbeg, kend integer jlen, klen ieqst = -1 if( jend < jbeg - 1 ) return if( kend < kbeg - 1 ) return jlen = jend - jbeg + 1 klen = kend - kbeg + 1 if( jlen != klen ) return if( jlen == 0 ) return(0) for( i = 0 ; i <= jlen - 1 ; i = i + 1 ) { c1 = jstr( jbeg + i ) c2 = kstr( kbeg + i ) if( c1 != c2 & c1 != wildch & c2 != wildch ) return } return(0) end #-t- ieqst 577 ascii 15-Jan-84 13:57:52 #-h- impld 553 ascii 15-Jan-84 13:57:52 ### Impld Implode a list of symbols into a string. LISPVAL function impld() include lspcm integer i, junk integer min0 LISPVAL str, symlst LISPVAL atom, atm, get, MAKSTRING, stget string nilstr "nil" symlst = areg i = 1 while( atom( symlst) == NIL ) { areg = car( symlst) atm = areg if( atm == T ) call chcopy( 't', strbuf, i) else if( atm == NIL ) call stcopy( nilstr, 1, strbuf, i) else { breg = QPNAME str = get() junk = stget( str, strbuf, i) } symlst = cdr( symlst) } return( MAKSTRING( strbuf)) end #-t- impld 553 ascii 15-Jan-84 13:57:52 #-h- indx 631 ascii 15-Jan-84 13:57:53 LISPVAL function indx() include lspcm LISPVAL istg1, istg2, mknum integer i, len1, len2, ieqst integer buf1(MAX_STRING), buf2(MAX_STRING) LISPVAL STRINGP istg1 = areg istg2 = breg if( STRINGP(istg1) == NIL | STRINGP(istg2) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } len1 = 1 call stget( istg1, buf1, len1) len2 = 1 call stget( istg2, buf2, len2) if( len1 > len2 ) { call errlg( STRING_ERROR, NUMERIC_VALUE) return(QERROR) } for( i = 1 ; i <= len2 - len1 + 1 ; i = i + 1 ) { if( ieqst( buf1, 1, len1, buf2, i, i + len1 - 1 ) == 0 ) return( mknum( float(i))) } return(NIL) end #-t- indx 631 ascii 15-Jan-84 13:57:53 #-h- indxx 457 ascii 15-Jan-84 13:57:53 integer function indxx( jstr, jbeg, jend, kstr, kbeg, kend) character jstr(ARB), kstr(ARB) integer jbeg, jend, kbeg, kend integer jlen, klen integer ieqst # function(s) indxx = -1 if( jbeg > jend ) return if( kbeg > kend ) return klen = kend - kbeg + 1 jlen = jend - jbeg + 1 if( klen > jlen ) return for( i = jbeg ; i <= jend - klen + 1 ; i = i + 1 ) if( ieqst( jstr, i, i + klen - 1, kstr, kbeg, kend) == 0 ) return(i) return end #-t- indxx 457 ascii 15-Jan-84 13:57:53 #-h- inpop 206 ascii 15-Jan-84 13:57:53 ### InPop Pop the input file stack. Exit if at bottom of stack. subroutine inpop include lspcm if( inplvl <= 1 ) call endst(OK) else { call close(inpstk(inplvl)) inplvl = inplvl - 1 } return end #-t- inpop 206 ascii 15-Jan-84 13:57:53 #-h- inpush 475 ascii 15-Jan-84 13:57:54 ### InPush Push chan onto input stack, making it the current input. LISPVAL function inpush() include lspcm LISPVAL chan LISPVAL gtent chan = areg ifdef( CHECK_ARGUMENTS ) if( car(chan) != QICHANNEL & car(chan) != QOCHANNEL ) { call errlg( IO_ERROR, TRUTH_VALUE) return(QERROR) } enddef if( inplvl > MAX_INPUT_LEVELS ) { call error(" ? Too many input levels.") call toplv } else { inplvl = inplvl + 1 inpstk(inplvl) = gtent( cdr(chan)) } return(T) end #-t- inpush 475 ascii 15-Jan-84 13:57:54 #-h- inten 2046 ascii 15-Jan-84 13:57:54 ### Inten "Intern" a symbol. LISPVAL function inten( buf) # The function INTERN takes the string in BUF and searches for the # corresponding ATOM on the OBLIST. If it does not find an ATOM then it # creates one and puts it on the OBLIST. include lspcm character buf(ARB), buf2(MAX_STRING) LISPVAL p, nextp, pp, cell, PUTPROP LISPVAL MAKSTRING, sloc LISPVAL mksym integer i, len, h, k, n integer hash, slen integer jscom, stget integer length # function(s) len = length(buf) # See if the atom is T or NIL. i = jscom( "nil", 1, 3, buf, 1, len) if( i == 0 ) return(NIL) i = jscom( "t", 1, 1, buf, 1, len) if( i == 0 ) return(T) pp = NIL # Find the proper bucket on the oblist h = hash( buf, len) p = oblist(h) # If there is nothing on the OBLIST then put the ATOM there. if( p == NIL ) { cell = mksym() i = MAKSTRING(buf) areg = cell breg = QUNBOUND creg = QVALUE n = PUTPROP() inten = cell areg = cell breg = i creg = QPNAME n = PUTPROP() oblist(h) = cons( cons( cell, i), NIL) } else { # Get the PNAME from the OBLIST and compare it with the string in BUF. # Do this on the OBLIST until a match is found or not. # (The entries on the OBLIST are in alphabetical order). sloc = cdr( car(p)) slen = 1 slen = stget( sloc, buf2, slen) i = jscom( buf2, 1, slen, buf, 1, len) while( i > 0 ) { pp = p p = cdr(p) if( p == NIL ) break sloc = cdr( car(p)) slen = 1 slen = stget( sloc, buf2, slen) i = jscom( buf2, 1, slen, buf, 1, len) } # If the ATOM was not found, then create a new one. if( i != 0 ) { cell = mksym() k = MAKSTRING(buf) areg = cell breg = QUNBOUND creg = QVALUE n = PUTPROP() inten = cell areg = cell breg = k creg = QPNAME n = PUTPROP() nextp = cons( cons( cell, k), p) if( pp == 0 ) oblist(h) = nextp else # Stick it on the OBLIST. RPLACD( pp, nextp) } # If the ATOM was found then return that value. else if( i == 0 ) inten = car( car(p)) } return end #-t- inten 2046 ascii 15-Jan-84 13:57:54 #-h- intn2 308 ascii 15-Jan-84 13:57:55 LISPVAL function intn2() include lspcm LISPVAL strg LISPVAL INTERN LISPVAL STRINGP integer len strg = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(strg) == NIL ) { call errlg( ARGUMENT_ERROR, ATOMIC_VALUE) return(QERROR) } enddef len = 1 call stget( strg, t1buf, len) return( INTERN(t1buf)) end #-t- intn2 308 ascii 15-Jan-84 13:57:55 #-h- ipopa 79 ascii 15-Jan-84 13:57:55 function ipopa() include lspcm ipopa = dstack(dsp) dsp = dsp - 1 return end #-t- ipopa 79 ascii 15-Jan-84 13:57:55 #-h- isful 150 ascii 15-Jan-84 13:57:56 ### IsFul Report whether the DATA_STACK is full. PREDICATE isful() include lspcm if( dsp == DATA_STACK_SIZE ) return(T) else return(NIL) end #-t- isful 150 ascii 15-Jan-84 13:57:56 #-h- jctxt 449 ascii 15-Jan-84 13:57:56 subroutine jctxt include lspcm # This is one of the few cases where we force the user back to the # TOPLEVEL after an error. if( prptr == 1 ) { call errlg( NOPROG_ERROR, RESTART_LISP) call brkp call toplv } prptr = prptr - 4 cptr = prstk(prptr) # Restore the context stack. progsp = prstk( prptr + 1 ) dsp = prstk( prptr + 2 ) call unwnd( prstk( prptr + 3 )) # UNWIND the binding context stack to where # where is was before. return end #-t- jctxt 449 ascii 15-Jan-84 13:57:56 #-h- jscom 531 ascii 15-Jan-84 13:57:56 integer function jscom( jstr, jbeg, jend, kstr, kbeg, kend) character jstr(ARB), kstr(ARB) integer jbeg, jend, kbeg, kend integer jlen, klen jlen = jend - jbeg + 1 klen = kend - kbeg + 1 len = min0( jlen, klen) jscom = 1 jchr = jstr(jbeg) kchr = kstr(kbeg) for( i = 1 ; i <= len - 1 & jchr == kchr ; i = i + 1 ) { jchr = jstr( jbeg + i ) kchr = kstr( kbeg + i ) } if( jchr == kchr ) { if( jlen > klen ) return(-1) else if( jlen < klen ) return else return(0) } else if( jchr < kchr ) return(-1) end #-t- jscom 531 ascii 15-Jan-84 13:57:56 #-h- ldfil 169 ascii 15-Jan-84 13:57:57 ### LdFil Load a file, using search path. PREDICATE ldfil(fil) include lspcm character fil(ARB) LISPVAL load, MAKSTRING areg = MAKSTRING(fil) return( load()) end #-t- ldfil 169 ascii 15-Jan-84 13:57:57 #-h- lesp 482 ascii 15-Jan-84 13:57:57 ### LesP "Less" predicate for numbers and strings. PREDICATE lesp() include lspcm LISPVAL val, i, j integer ilen, jlen, stcom integer strln real numvl LISPVAL NUMBERP, STRINGP i = areg j = breg if( NUMBERP(i) == T & NUMBERP(j) == T ) { ab = numvl(i) cd = numvl(j) if( ab < cd ) lesp = T else lesp = NIL } else if( STRINGP(i) == T & STRINGP(j) == T ) { val = stcom( i, j) if( val < 0 ) lesp = T else lesp = NIL } else lesp = NIL return end #-t- lesp 482 ascii 15-Jan-84 13:57:57 #-h- lg10x 314 ascii 15-Jan-84 13:57:58 ### Lg10x Return the common log of x. integer function lg10x() include lspcm LISPVAL NUMBERP LISPVAL mknum, i real numvl, alog10 real val i = areg if( NUMBERP(i) != NIL ) { val = numvl(i) if( val > 0.0 ) return( mknum( alog10( val))) } call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) end #-t- lg10x 314 ascii 15-Jan-84 13:57:58 #-h- lis01 3023 ascii 15-Jan-84 13:57:58 # The most frequently called functions are in this segment. subroutine lis01 include lspcm # The functions in this segment must be listed as external for # their entry points to be put on their property lists. external gensm, caar, cadr, cdar, cddr, membr, membq external nconc, plus, diffr, times, divd, minsp, grtp external lesp, add1,sub1, absv, entir, oddp, evenp external expt, fixp, fix, sbstr, indx, conct, expld external sleng, defun, minus, minx, maxx, stats, chrps external lmod, sqrtx, rndom, sinx, cosx, tanx, acosx, asinx external atanx, expx, lg10x, logx, impld, pname, fldstr, uprstr integer i LISPVAL smakfn LISPVAL INTERN LISPVAL getvl if( parm(1) >= 0 ) return i = smakfn( 1, "add1", qsubr, addrs(add1)) i = smakfn( 1, "sub1", qsubr, addrs(sub1)) i = smakfn( 1, "member", qsubr, addrs(membr)) i = smakfn( 1, "membq", qsubr, addrs(membq)) i = smakfn( 1, "nconc", qsubr, addrs(nconc)) i = smakfn( 1, "charpos", qsubr, addrs(chrps)) i = smakfn( 1, "defun", QFSUBR, addrs(defun)) i = smakfn( 1, "substr", qsubr, addrs(sbstr)) i = smakfn( 1, "index", qsubr, addrs(indx)) i = smakfn( 1, "concat", qlsubr, addrs(conct)) i = smakfn( 1, "explode", qsubr, addrs(expld)) i = smakfn( 1, "absval", qsubr, addrs(absv)) i = smakfn( 1, "entier", qsubr, addrs(entir)) i = smakfn( 1, "evenp", qsubr, addrs(evenp)) i = smakfn( 1, "oddp", qsubr, addrs(oddp)) i = smakfn( 1, "expt", qsubr, addrs(expt)) i = smakfn( 1, "fixp", qsubr, addrs(fixp)) i = smakfn( 1, "fix", qsubr, addrs(fix)) i = smakfn( 1, "mod", qsubr, addrs(lmod)) i = smakfn( 1, "slen", qsubr, addrs(sleng)) i = smakfn( 1, "min", qlsubr, addrs(minx)) i = smakfn( 1, "max", qlsubr, addrs(maxx)) i = smakfn( 1, "status", qsubr, addrs(stats)) i = smakfn( 1, "plus", qlsubr, addrs(plus)) i = smakfn( 1, "difference", qsubr, addrs(diffr)) i = smakfn( 1, "minus", qsubr, addrs(minus)) i = smakfn( 1, "times", qlsubr, addrs(times)) i = smakfn( 1, "divide", qsubr, addrs(DIVIDE)) call setvl( INTERN( "quotient"), getvl(i)) i = smakfn( 1, "minusp", qsubr, addrs(minsp)) i = smakfn( 1, "greaterp", qsubr, addrs(grtp)) i = smakfn( 1, "lessp", qsubr, addrs(lesp)) i = smakfn( 1, "gensym", qsubr, addrs(gensm)) i = smakfn( 1, "caar", qsubr, addrs(caar)) i = smakfn( 1, "cadr", qsubr, addrs(cadr)) i = smakfn( 1, "cddr", qsubr, addrs(cddr)) i = smakfn( 1, "cdar", qsubr, addrs(cdar)) i = smakfn( 1, "sqrt", qsubr, addrs(sqrtx)) i = smakfn( 1, "random", qsubr, addrs(rndom)) i = smakfn( 1, "sin", qsubr, addrs(sinx)) i = smakfn( 1, "cos", qsubr, addrs(cosx)) i = smakfn( 1, "tan", qsubr, addrs(tanx)) i = smakfn( 1, "acos", qsubr, addrs(acosx)) i = smakfn( 1, "asin", qsubr, addrs(asinx)) i = smakfn( 1, "atan", qsubr, addrs(atanx)) i = smakfn( 1, "exp", qsubr, addrs(expx)) i = smakfn( 1, "log10", qsubr, addrs(lg10x)) i = smakfn( 1, "log", qsubr, addrs(logx)) i = smakfn( 1, "implode", qsubr, addrs(impld)) i = smakfn( 1, "get_pname", qsubr, addrs(pname)) i = smakfn( 1, "fold", qsubr, addrs(fldstr)) i = smakfn( 1, "upper", qsubr, addrs(uprstr)) return end #-t- lis01 3023 ascii 15-Jan-84 13:57:58 #-h- lis02 344 ascii 15-Jan-84 13:57:59 # This segment contains the READ functions. subroutine lis02 include lspcm LISPVAL smakfn external read, ratom, rhead, rtail, reade LISPVAL i if( parm(1) >= 0 ) return qread = smakfn( 2, "read", qsubr, addrs(reade)) readfn = addrs(read) i = smakfn( 2, "ratom", qsubr, addrs(ratom)) rheadf = addrs(rhead) rtailf = addrs(rtail) return end #-t- lis02 344 ascii 15-Jan-84 13:57:59 #-h- lis03 710 ascii 15-Jan-84 13:57:59 # This segment contains all the PRINT functions. subroutine lis03 include lspcm external print, princ, tyo, dotpt, terpi external shwst, shwfr, patm2 LISPVAL smakfn, qshwct, qshwfr, qtyo, qterpi LISPVAL qprinc LISPVAL i if( parm(1) >= 0 ) return QPRINT = smakfn( 3, "print", qsubr, addrs(print)) printf = addrs(print) dotptf = addrs(dotpt) qprinc = smakfn( 3, "princ", qsubr, addrs(princ)) qdotpt = smakfn( 3, "dotprint", qsubr, addrs(dotpt)) qterpi = smakfn( 3, "terpri", qsubr, addrs(terpi)) i = smakfn( 3, "patom", qsubr, addrs(patm2)) qtyo = smakfn( 3, "tyo", qsubr, addrs(tyo)) qshwst = smakfn( 3, "showstack", qsubr, addrs(shwst)) qshwfr = smakfn( 3, "showforms", qsubr, addrs(shwfr)) return end #-t- lis03 710 ascii 15-Jan-84 13:57:59 #-h- lis04 717 ascii 15-Jan-84 13:57:59 # This segment contaiins a few auxillary functions. There is room # to add more without adding a new segment. subroutine lis04 include lspcm LISPVAL smakfn LISPVAL INTERN external fnctn, defne, rmprp, intn2, eshell, dospwn, cwd, oblst LISPVAL qfnctn, qdefne LISPVAL ifunc if( parm(1) >= 0 ) return qfnctn = smakfn( 4, "function", QFSUBR, addrs(fnctn)) qdefne = smakfn( 4, "define", QFSUBR, addrs(defne)) ifunc = smakfn( 4, "remprop", qsubr, addrs(rmprp)) ifunc = smakfn( 4, "intern", qsubr, addrs(intn2)) ifunc = smakfn( 4, "sh", qsubr, addrs(eshell)) ifunc = smakfn( 4, "spawn", qsubr, addrs(dospwn)) ifunc = smakfn( 4, "cd", qsubr, addrs(cwd)) ifunc = smakfn( 4, "oblist", qsubr, addrs(oblst)) return end #-t- lis04 717 ascii 15-Jan-84 13:57:59 #-h- lis05 383 ascii 15-Jan-84 13:58:00 # This segment contains all the array operations except STORE. subroutine lis05 include lspcm LISPVAL smakfn LISPVAL INTERN external array, uarry, acces LISPVAL qunrry LISPVAL qacces if( parm(1) >= 0 ) return qarray = smakfn( 5, "array", qlsubr, addrs(array)) qunrry = smakfn( 5, "unarray", qsubr, addrs(uarry)) qacces = smakfn( 5, "access", qsubr, addrs(acces)) return end #-t- lis05 383 ascii 15-Jan-84 13:58:00 #-h- list 729 ascii 15-Jan-84 13:58:00 LISPVAL function list() include lspcm LISPVAL last, arglst, iele, eval ENTRY_POINT list = NIL arglst = areg if( arglst == NIL ) { list = NIL RETURN_VALUE(NIL) } list = cons( NIL, NIL) last = list while( arglst != NIL ) { PUSH(list) PUSH(last) PUSH(arglst) areg = car(arglst) iele = eval() arglst = cdr(POP) last = POP RPLACA( last, iele) if( arglst == NIL ) { list = POP break } RPLACD( last, cons( NIL, NIL)) last = cdr(last) list = POP # This is here for a reason. The garbage collector # looks on the data stack for nodes in use. If # we are constructing a very long list then it # had better be on the data stack or it may get # missed. } RETURN_VALUE(list) end #-t- list 729 ascii 15-Jan-84 13:58:00 #-h- lmod 329 ascii 15-Jan-84 13:58:01 LISPVAL function lmod() include lspcm LISPVAL mknum, i, j real numvl, amod LISPVAL NUMBERP i = areg j = breg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL | NUMBERP(j) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef ab = numvl(i) cd = numvl(j) ab = amod( ab, cd) return( mknum(ab)) end #-t- lmod 329 ascii 15-Jan-84 13:58:01 #-h- lngst 230 ascii 15-Jan-84 13:58:01 ### LngSt Return the "length" of a string. integer function lngst( buf, n) character c, buf(ARB) integer len len = n c = buf(len) while( ( c == ' ' | c == 0 ) & len >= 1 ) { len = len - 1 c = buf(len) } return(len) end #-t- lngst 230 ascii 15-Jan-84 13:58:01 #-h- load 1353 ascii 15-Jan-84 13:58:02 ### Load Load a file. PREDICATE load() include lspcm include cflag character fil(FILENAMESIZE), nam(FILENAMESIZE), path(FILENAMESIZE) integer ev, i, junk, len, rd integer inpush, length, loccom, stget LISPVAL eval, filnam, jcall, chn, opnfil, MAKSTRING LISPVAL reade string suffix LISP_SUFFIX ENTRY_POINT filnam = areg i = 1 len = stget( filnam, fil, i) call impath(path) repeat # Not really... { if( loccom( fil, path, suffix, nam) != ASCII ) break call mkpath( nam, path) # Reuse path areg = MAKSTRING(path) breg = QRDACC filnam = areg chn = opnfil() if( chn == QERROR ) break if( quiet == NO ) { PRINTCH('L') PRINTCH('o') PRINTCH('a') PRINTCH('d') PRINTCH('i') PRINTCH('n') PRINTCH('g') PRINTCH(' ') LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) junk = jcall(printf) PRINTCH(' ') PRINTCH('.') PRINTCH('.') PRINTCH('.') TERPRI } PUSH(chn) areg = chn junk = inpush() repeat { rd = reade() areg = rd ev = eval() LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) if( verbos == YES ) { areg = ev junk = jcall(printf) PRINTCH(' ') } } until( rd == NIL & ev == NIL ) call inpop areg = POP junk = jcall(clsf) if( verbos == YES ) TERPRI RETURN_VALUE(T) } RETURN_VALUE(NIL) end #-t- load 1353 ascii 15-Jan-84 13:58:02 #-h- lodsg 480 ascii 15-Jan-84 13:58:02 ### LodSg Load a segment (overlay). subroutine lodsg( iseg, ip1, ip2, ip3, ip4, ip5) include lspcm integer iseg, ip1, ip2, ip3, ip4, ip5 if( iseg == CURRSEG ) return CURRSEG = iseg assign 1000 to rtnadr parm(1) = ip1 parm(2) = ip2 parm(3) = ip3 parm(4) = ip4 parm(5) = ip5 switch( iseg ) { case 1: call lis01 case 2: call lis02 case 3: call lis03 case 4: call lis04 case 5: call lis05 default: call remark( "? Bad LODSG call." ) } 1000 continue return end #-t- lodsg 480 ascii 15-Jan-84 13:58:02 #-h- logx 311 ascii 15-Jan-84 13:58:02 ### Logx Return the natural log of x. LISPVAL function logx() include lspcm LISPVAL NUMBERP LISPVAL mknum, i real numvl, alog real val i = areg if( NUMBERP(i) != NIL ) { val = numvl(i) if( val > 0.0 ) return( mknum( alog( val))) } call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) end #-t- logx 311 ascii 15-Jan-84 13:58:02 #-h- makfn 216 ascii 15-Jan-84 13:58:03 LISPVAL function makfn( strg, type, adr) include lspcm LISPVAL INTERN LISPVAL mksbr LISPVAL i character strg LISPVAL type ADDRESS adr i = INTERN(strg) call setvl( i, cons( type, mksbr(adr))) return(i) end #-t- makfn 216 ascii 15-Jan-84 13:58:03 #-h- maksg 597 ascii 15-Jan-84 13:58:03 ### MakSg Convert the EOS-terminated string in "buf" into a LISP string. ### Return the address of the string in DATA_SPACE. LISPVAL function maksg(buf) include lspcm include lspem character buf(ARB) integer i, len integer heap, length # function(s) LISPVAL p LISPVAL gcs # function(s) len = length(buf) if( stptr + len > STRING_SPACE ) if( gcs() == NIL ) call error( "? String Space Full." ) p = heap() AUX_FIELD(p) = STRING_BIT CAR_FIELD(p) = len CDR_FIELD(p) = stptr for( i = 1 ; i <= len ; i = i + 1 ) strngs( stptr - 1 + i ) = buf(i) stptr = stptr + len return(p) end #-t- maksg 597 ascii 15-Jan-84 13:58:03 #-h- mark1 1249 ascii 15-Jan-84 13:58:04 ### Mark1 Internal Garbage Collector routine. subroutine mark1(node) # MARK1 uses the data stack as long as it is not full. When the data # stack gets full, then MARK1 calls MARK2 which uses a pointer bending # algorithm which only uses the TAG_BIT. include lspcm include lspem LISPVAL node LISPVAL isful LISPVAL p, q integer auxf # Check to make sure that this node is MARKable. if( node <= INUM | node == NIL | node == T ) return # If the node is an ATOM then we need go no further. if( NODE_IS_ATOM_HEADER(node) ) { MARK_NODE(node) return } p = node if( NODE_IS_MARKED(p) ) return else MARK_NODE(p) PUSH(T) # We push T on the data stack so that we can tell when # we have come back to where we started. repeat { repeat { q = CDR_FIELD(p) if( q > INUM & q != NIL & q != T ) { if( NODE_IS_NOT_ATOM_HEADER(q) & NODE_IS_NOT_MARKED(q) ) { if( isful() == T ) call mark2(q) else PUSH(q) } MARK_NODE(q) } p = CAR_FIELD(p) if( p <= INUM | p == NIL | p == T ) break if( NODE_IS_MARKED(p) ) break else MARK_NODE(p) if( NODE_IS_ATOM_HEADER(p) ) break } p = POP if( p == T ) return } return end #-t- mark1 1249 ascii 15-Jan-84 13:58:04 #-h- mark2 1213 ascii 15-Jan-84 13:58:04 ### Mark2 Internal Garbage Collector routine. subroutine mark2(node) # MARK2 is the pointer bending algorithm given in Horowitz and Sahni # Fundementals of Data Structures. include lspcm include lspem LISPVAL node LISPVAL p, s, tail integer auxf if( node <= INUM | node == NIL | node == T ) return if( NODE_IS_ATOM_HEADER(node) ) { MARK_NODE(node) return } p = node tail = NIL if( NODE_IS_MARKED(p) ) return else MARK_NODE(p) repeat { s = CAR_FIELD(p) if( s > INUM & s != NIL & s != T ) { if( NODE_IS_NOT_MARKED(s) & NODE_IS_TAGGED(s) ) { MARK_NODE(s) UNTAG_NODE(s) CAR_FIELD(p) = tail tail = p p = s next } MARK_NODE(s) } 1000 s = CDR_FIELD(p) if( s > INUM & s != NIL & s != T ) { if( NODE_IS_NOT_MARKED(s) & NODE_IS_TAGGED(s) ) { MARK_NODE(s) CDR_FIELD(p) = tail tail = p p = s next } MARK_NODE(s) } while( tail != NIL ) { s = tail if( NODE_IS_NOT_TAGGED(s) ) { tail = CAR_FIELD(s) CAR_FIELD(s) = p TAG_NODE(s) p = s goto 1000 } tail = CDR_FIELD(s) CDR_FIELD(s) = p p = s } } until( tail == NIL ) return end #-t- mark2 1213 ascii 15-Jan-84 13:58:04 #-h- maxx 443 ascii 15-Jan-84 13:58:05 ### Maxx Return the max of a list of numbers. LISPVAL function maxx() include lspcm LISPVAL mknum, iargl, eval LISPVAL NUMBERP real numvl, x iargl = areg ab = -1.0e38 while( iargl != NIL ) { ifdef( CHECK_ARGUMENTS ) if( NUMBERP( car(iargl)) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef x = numvl( car(iargl)) iargl = cdr(iargl) if( x > ab ) ab = x } return( mknum(ab)) end #-t- maxx 443 ascii 15-Jan-84 13:58:05 #-h- membq 252 ascii 15-Jan-84 13:58:05 LISPVAL function membq() include lspcm LISPVAL lst, ele LISPVAL eq, atom ele = areg lst = breg while( atom(lst) == NIL ) { if( eq( ele, car(lst)) == T ) break lst = cdr(lst) } if( atom(lst) == T ) return(NIL) else return(lst) end #-t- membq 252 ascii 15-Jan-84 13:58:05 #-h- membr 299 ascii 15-Jan-84 13:58:06 LISPVAL function membr() include lspcm LISPVAL lst, equal2, ele, i LISPVAL atom ele = areg lst = breg while( atom(lst) == NIL ) { areg = ele breg = car(lst) i = equal2() if( i == NIL ) lst = cdr(lst) else break } if( atom(lst) == T ) return(NIL) else return(lst) end #-t- membr 299 ascii 15-Jan-84 13:58:06 #-h- minsp 303 ascii 15-Jan-84 13:58:06 ### MinsP "Minus" predicate. PREDICATE minsp() include lspcm LISPVAL NUMBERP LISPVAL i real numvl, x i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef x = numvl(i) if( x < 0.0 ) return(T) else return(NIL) end #-t- minsp 303 ascii 15-Jan-84 13:58:06 #-h- minus 303 ascii 15-Jan-84 13:58:06 ### Minus Implement the "minus" function. LISPVAL function minus() include lspcm LISPVAL i LISPVAL NUMBERP LISPVAL mknum real numvl i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( -numvl(i))) end #-t- minus 303 ascii 15-Jan-84 13:58:06 #-h- minx 444 ascii 15-Jan-84 13:58:07 ### MinX Return the min of a list of numbers. LISPVAL function minx() include lspcm LISPVAL mknum, iargl, eval LISPVAL NUMBERP real numvl, x iargl = areg ab = +1.0e38 while( iargl != NIL ) { ifdef( CHECK_ARGUMENTS ) if( NUMBERP( car(iargl)) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef x = numvl( car(iargl)) iargl = cdr(iargl) if( x < ab ) ab = x } return( mknum(ab)) end #-t- minx 444 ascii 15-Jan-84 13:58:07 #-h- mknum 407 ascii 15-Jan-84 13:58:07 ### MkNum Create a number. LISPVAL function mknum(x) include lspcm LISPVAL p integer r1, r2 integer heap # function(s) real x, y integer ir(2) equivalence ( ir, y), ( r1, ir(1)), ( r2, ir(2)) if( aint(x) == x ) if( x >= -INUM / 2 & x <= INUM / 2 - 1 ) return( iabs( ifix(x) + INUM / 2 ) + 1) y = x p = heap() AUX_FIELD(p) = FLONUM_BIT CAR_FIELD(p) = r1 CDR_FIELD(p) = r2 return(p) end #-t- mknum 407 ascii 15-Jan-84 13:58:07 #-h- mksbr 248 ascii 15-Jan-84 13:58:08 ### MkSbr Take an address and create a SUBR entry point. LISPVAL function mksbr(adr) include lspcm ADDRESS adr integer heap # function(s) mksbr = heap() AUX_FIELD(mksbr) = SUBR_BIT CAR_FIELD(mksbr) = adr CDR_FIELD(mksbr) = NIL return end #-t- mksbr 248 ascii 15-Jan-84 13:58:08 #-h- mksym 220 ascii 15-Jan-84 13:58:08 ### MkSym Return a node for a symbol. LISPVAL function mksym() include lspcm LISPVAL heap # function(s) mksym = heap() AUX_FIELD(mksym) = SYMBOL_BIT CAR_FIELD(mksym) = QUNBOUND CDR_FIELD(mksym) = NIL return end #-t- mksym 220 ascii 15-Jan-84 13:58:08 #-h- nconc 384 ascii 15-Jan-84 13:58:08 ### Nconc Implement the "nconc" function. integer function nconc() include lspcm LISPVAL lst, arg1, arg2 LISPVAL atom arg1 = areg arg2 = breg nconc = arg1 if( arg1 == NIL ) nconc = arg2 else if( atom(arg1) == T ) { nconc = QERROR call errlg( ARGUMENT_ERROR, ANYTHING) } else { while( atom( cdr(arg1)) == NIL ) arg1 = cdr(arg1) RPLACD( arg1, arg2) } return end #-t- nconc 384 ascii 15-Jan-84 13:58:08 #-h- nul2 88 ascii 15-Jan-84 13:58:09 PREDICATE nul2() include lspcm if( areg == NIL ) return(T) else return(NIL) end #-t- nul2 88 ascii 15-Jan-84 13:58:09 #-h- num2 97 ascii 15-Jan-84 13:58:09 PREDICATE num2() include lspcm LISPVAL NUMBERP LISPVAL i i = areg return( NUMBERP(i)) end #-t- num2 97 ascii 15-Jan-84 13:58:09 #-h- numc 154 ascii 15-Jan-84 13:58:09 ### NumC Determine whether a character is numeric. PREDICATE numc(c) include lspcm character c if( IS_DIGIT(c) ) return(T) else return(NIL) end #-t- numc 154 ascii 15-Jan-84 13:58:09 #-h- nump 253 ascii 15-Jan-84 13:58:10 ### NumP Determine whether the argument is a number. PREDICATE nump(i) include lspcm LISPVAL i if( i == NIL | i == T ) nump = NIL else if( i <= INUM ) nump = T else if( EXAMINE( i - 1 ) == FLONUM_BIT ) nump = T else nump = NIL return end #-t- nump 253 ascii 15-Jan-84 13:58:10 #-h- numvl 290 ascii 15-Jan-84 13:58:10 ### NumVl Retuen the (real) value of a number. real function numvl(i) include lspcm LISPVAL i integer r1, r2 real y integer ir(2) equivalence ( y, ir), ( ir(1), r1), ( ir(2), r2) if( i <= INUM ) return( float( i - INUM/2 - 1 )) r1 = EXAMINE(i) r2 = EXAMINE(i+1) return(y) end #-t- numvl 290 ascii 15-Jan-84 13:58:10 #-h- oblst 419 ascii 15-Jan-84 13:58:11 ### Oblst Return a list of all the objects on the oblist. LISPVAL function oblst() include lspcm integer i LISPVAL p, q oblst = cons( NIL, NIL) for( i = OBLIST_LENGTH ; i >= 1 ; i = i - 1 ) { p = oblist(i) while( p != NIL ) { q = car( car(p)) if( q != qdot & q != qblnk & q != qlpar & q != qrpar & q != qquote & q != QERROR ) oblst = cons( q, oblst) p = cdr(p) } } return end #-t- oblst 419 ascii 15-Jan-84 13:58:11 #-h- oddp 378 ascii 15-Jan-84 13:58:11 ### OddP Determine whether a number is odd. PREDICATE oddp() include lspcm LISPVAL i LISPVAL NUMBERP real numvl, x i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, TRUTH_VALUE) return(QERROR) } enddef x = numvl(i) if( float( ifix(x)) != x ) oddp = NIL else if( amod( x, 2.0 ) != 0.0 ) oddp = T else oddp = NIL return end #-t- oddp 378 ascii 15-Jan-84 13:58:11 #-h- ok 326 ascii 15-Jan-84 13:58:11 ### Ok Determine whether the character is OK for starting an ATOM. PREDICATE ok(n) include lspcm character n ok = T switch( n ) { case ' ', COMMENTCHAR, '"', QUOTESYMBOL, '(', ')', ',', '.', '[', ']': ok = NIL case '+', '-': if( ('0' <= icbuf(icptr)) & (icbuf(icptr) <= '9') ) ok = NIL } return end #-t- ok 326 ascii 15-Jan-84 13:58:11 #-h- opnfil 786 ascii 15-Jan-84 13:58:12 ### OpnFil Open a file for READ, WRITE or APPEND access. LISPVAL function opnfil() include lspcm character fil(FILENAMESIZE) filedes fd filedes open # function(s) integer stget # function(s) LISPVAL accmod, filnam LISPVAL mksbr, STRINGP # function(s) integer i filnam = areg # Get file spec. accmod = breg # Get access mode. ifdef( CHECK_ARGUMENTS ) if( STRINGP(filnam) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 i = stget( filnam, fil, i) if( accmod == QRDACC ) fd = open( fil, READ) else if( accmod == QWRACC ) fd = open( fil, WRITE) else if( accmod == QAPACC ) fd = open( fil, APPEND) else return(NIL) if( accmod == QRDACC ) return( cons( QICHANNEL, mksbr( fd))) else return( cons( QOCHANNEL, mksbr( fd))) end #-t- opnfil 786 ascii 15-Jan-84 13:58:12 #-h- orf 432 ascii 15-Jan-84 13:58:12 ### Orf Perform the logical "or" function. LISPVAL function orf() # The OR function is implemented as an FSUBR. As soon as one of the # arguments to OR is non-NIL then EVALuation stops. include lspcm LISPVAL tval, arglst, eval ENTRY_POINT orf = NIL arglst = areg tval = NIL while( arglst != NIL & tval == NIL ) { PUSH(arglst) areg = car(arglst) tval = eval() arglst = cdr(POP) } orf = tval RETURN_VALUE(tval) end #-t- orf 432 ascii 15-Jan-84 13:58:12 #-h- patm2 108 ascii 15-Jan-84 13:58:13 LISPVAL function patm2() include lspcm LISPVAL arg LISPVAL patom arg = areg return( patom(arg)) end #-t- patm2 108 ascii 15-Jan-84 13:58:13 #-h- patom 1263 ascii 15-Jan-84 13:58:13 ### PAtom Print an ATOM. LISPVAL function patom(atm) include lspcm character buf(20) character chget # function(s) LISPVAL atm, pnumb, PSTRING, PSYMBOL LISPVAL str LISPVAL get integer strln, len integer i integer k LISPVAL SYMBOLP, STRINGP, NUMBERP LISPVAL atom LISPVAL subrp integer gtent patom = atm # A check on the interpreter. if( atom(atm) == NIL ) call perr if( atm == NIL ) { if( pcptr + 4 > LINE_LENGTH ) TERPRI PRINTCH('n') PRINTCH('i') PRINTCH('l') } else if( atm == T ) PRINTCH('t') else if( SYMBOLP(atm) == T ) { areg = atm breg = QPNAME str = get() if( STRINGP(str) == NIL ) call perr len = strln(str) if( pcptr + len + 1 > LINE_LENGTH ) TERPRI for( i = 1 ; i <= len ; i = i + 1 ) PRINTCH( chget( str, i)) } else if( STRINGP(atm) == T ) { len = strln(atm) if( pcptr + len + 3 > LINE_LENGTH ) TERPRI PRINTCH('"') for( i = 1 ; i <= len ; i = i + 1 ) PRINTCH( chget( atm, i)) PRINTCH('"') } else if( subrp(atm) == T ) { if( pcptr + 7 > LINE_LENGTH ) TERPRI call cnumo( gtent(atm), buf) PRINTCH('#') for( k = 1 ; k <= 20 ; k = k + 1 ) if( buf(k) != ' ' ) PRINTCH( buf(k) ) } else if( NUMBERP(atm) == T ) patom = pnumb(atm) else call perr return end #-t- patom 1263 ascii 15-Jan-84 13:58:13 #-h- perr 244 ascii 15-Jan-84 13:58:13 ### Perr Error routine for "print" functions. subroutine perr include lspcm call errlg( LIST_ERROR, RESTART_LISP) # This is one of the places # call brkp # where the user is forced # call toplv # to go back to the TOPLEVEL. end #-t- perr 244 ascii 15-Jan-84 13:58:13 #-h- plus 423 ascii 15-Jan-84 13:58:14 ### Plus Implement the "plus" function. LISPVAL function plus() include lspcm LISPVAL mknum, i, arglst LISPVAL NUMBERP real numvl, sum arglst = areg sum = 0.0 while( arglst != NIL ) { ifdef( CHECK_ARGUMENTS ) if( NUMBERP( car(arglst)) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef sum = sum + numvl( car(arglst)) arglst = cdr(arglst) } return( mknum(sum)) end #-t- plus 423 ascii 15-Jan-84 13:58:14 #-h- pname 542 ascii 15-Jan-84 13:58:14 ### PName Return the "pname" of a symbol. LISPVAL function pname() include lspcm integer i, junk LISPVAL atm, str LISPVAL atom, get, MAKSTRING, stget # function(s) string nilstr "nil" atm = areg ifdef( CHECK_ARGUMENTS ) if( atom(atm) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 if( atm == T ) call chcopy( 't', strbuf, i) else if( atm == NIL ) call stcopy( nilstr, 1, strbuf, i) else { breg = QPNAME str = get() junk = stget( str, strbuf, i) } return( MAKSTRING( strbuf)) end #-t- pname 542 ascii 15-Jan-84 13:58:14 #-h- pnumb 768 ascii 15-Jan-84 13:58:15 ### PNumb Print a number (using FORTRAN formatter). LISPVAL function pnumb(i) include lspcm define(FLOATING_WIDTH,16) define(FRACTION_WIDTH,8) character buf(arith(FLOATING_WIDTH,*,FRACTION_WIDTH)) integer j LISPVAL i LISPVAL NUMBERP real numvl if( NUMBERP(i) == NIL ) call perr ab = numvl(i) if( pcptr + 9 > LINE_LENGTH ) TERPRI if( aint(ab) == ab & ab < MAX_INTEGER ) { j = ifix(ab) encode( FLOATING_WIDTH, 200, buf) j 200 format(i FLOATING_WIDTH) } else { encode( FLOATING_WIDTH, 100, buf) ab 100 format( g FLOATING_WIDTH . FRACTION_WIDTH ) for( j = FLOATING_WIDTH ; buf(j) == '0' | buf(j) == ' ' ; j = j - 1 ) buf(j) = ' ' } for( j = 1 ; j <= FLOATING_WIDTH ; j = j + 1 ) if( buf(j) != ' ' ) PRINTCH( buf(j) ) return(i) end #-t- pnumb 768 ascii 15-Jan-84 13:58:15 #-h- preal 1024 ascii 15-Jan-84 13:58:15 ### PReal Return the real (number) value of the argument. real function preal(buf) character buf(20), c integer i, n integer exp, signe real whole, fract real p real signm i = 1 c = buf(i) signm = +1. if( c == '-' | c == '+' ) { if( c == '-' ) signm = -1. i = i + 1 c = buf(i) } whole = 0.0 while( c >= '0' & c <= '9' ) { n = c - '0' whole = whole * 10. + float(n) i = i + 1 c = buf(i) } fract = 0.0 p = .1 if( c == '.' ) { i = i + 1 c = buf(i) while( c >= '0' & c <= '9' ) { n = c - '0' fract = fract + p * float(n) p = p / 10. i = i + 1 c = buf(i) } } exp = 0 signe = +1 if( c == 'e' | c == 'E' ) { i = i + 1 c = buf(i) if( c == '+' | c == '-' ) { if( c == '-' ) signe = -1 i = i + 1 c = buf(i) } while( c >= '0' & c <= '9' ) { exp = exp * 10 + c - '0' i = i + 1 c = buf(i) } } if( signe == 1 ) preal = signm * ( whole + fract ) * 10. ** exp else preal = signm * ( whole + fract ) / 10. ** exp return end #-t- preal 1024 ascii 15-Jan-84 13:58:15 #-h- princ 377 ascii 15-Jan-84 13:58:16 ### PrinC Print a string. LISPVAL function princ() include lspcm character chget # function(s) integer i, len integer strln # function(s) LISPVAL arg arg = areg len = strln(arg) # Check to make sure that the atom does not overflow the print buffer. if( len + 1 > LINE_LENGTH ) TERPRI for( i = 1 ; i <= len ; i = i + 1 ) PRINTCH( chget( arg, i)) return(arg) end #-t- princ 377 ascii 15-Jan-84 13:58:16 #-h- prinh 929 ascii 15-Jan-84 13:58:16 ### PrinH Put a character into the print buffer, flushing if necessary. integer function prinh(c) include lspcm character c, ptbl(129) data ptbl / 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 126, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, 121, 122, 123, 124, 125, 126, 127, 128 / prinh = 0 if( pcptr + 1 > LINE_LENGTH ) TERPRI pcptr = pcptr + 1 prbuf(pcptr) = ptbl(c+1) return end #-t- prinh 929 ascii 15-Jan-84 13:58:16 #-h- print 1297 ascii 15-Jan-84 13:58:17 ### Print Print LISP values in list or dot notation. LISPVAL function print() include lspcm LISPVAL radr, adr, ircr, i LISPVAL jcall LISPVAL atom LISPVAL patom ENTRY_POINT adr = areg radr = adr # If it is an atomic quantity then call DOT_PRINT. if( atom(adr) == T ) { radr = patom(adr) print = radr RETURN_VALUE(radr) } # Check for the ATOM T. # If the CDR is not ATOMic then it is a list. else if( atom( cdr(adr)) == NIL | cdr(adr) == NIL ) { PRINTCH('(') # PRINT as list notation as long as possible. while( atom( cdr(adr)) == NIL ) { PUSH(adr) PUSH(radr) areg = car(adr) i = jcall(printf) radr = POP adr = POP adr = cdr(adr) PRINTCH(' ') } PUSH(adr) PUSH(radr) areg = car(adr) i = jcall(printf) radr = POP adr = POP # If it is NIL then it is the end of the list. if( cdr(adr) == NIL ) { PRINTCH(')') print = radr RETURN_VALUE(radr) } else { PRINTCH('.') PUSH(adr) PUSH(radr) areg = cdr(adr) i = jcall(printf) radr = POP adr = POP PRINTCH(')') print = radr RETURN_VALUE(radr) } } else if( atom( cdr(adr)) == T ) { PUSH(adr) PUSH(radr) areg = adr DOT_PRINT radr = POP adr = POP print = radr RETURN_VALUE(radr) } else call perr return end #-t- print 1297 ascii 15-Jan-84 13:58:17 #-h- prmpt 701 ascii 15-Jan-84 13:58:17 ### Prmpt Implement "prompt" from LISP. LISPVAL function prmpt() include lspcm filedes fd filedes gtent # function(s) integer i, len integer prompt # function(s) LISPVAL chn, pstr LISPVAL MAKSTRING, stget, STRINGP # function(s) pstr = areg chn = breg ifdef( CHECK_ARGUMENTS ) if( STRINGP(pstr) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE ) return(QERROR) } if( chn != NIL & car(chn) != QICHANNEL ) { call errlg( IO_ERROR, RESTART_LISP) return(QERROR) } enddef if( chn == NIL ) fd = STDIN else fd = gtent( cdr( chn)) i = 1 i = stget( pstr, strbuf, i) len = prompt( strbuf, strbuf, fd) if( len == EOF ) return(NIL) strbuf(len) = EOS return( MAKSTRING( strbuf)) end #-t- prmpt 701 ascii 15-Jan-84 13:58:17 #-h- prog 2570 ascii 15-Jan-84 13:58:18 ### Prog Implement "prog". LISPVAL function prog() # This is location to which a RETURN will jump if one is exectuted. define(RETURNSTOP,1000) # This is the location to which a GO will jump if one is executed. define(GOSTOP,2000) # After the GO is executed, processing of the PROG will continue here. define(GOSTART,2001) include lspcm LISPVAL varlst LISPVAL getvl LISPVAL arglst LISPVAL val, eval LISPVAL iv LISPVAL form LISPVAL atom integer rtrvsp ENTRY_POINT prog = NIL # The labels for RETURNSTOP & GOSTOP are put in common so that the # GO and RETURN funct*s can access them. assign RETURNSTOP to rlabl assign GOSTOP to glabl # Also save the hardware stack pointer. progsp = rtrvsp() arglst = areg # Get the argument list. PUSH(arglst) areg = car(arglst) # We have to bind all the local variables to NIL. breg = NIL call bind arglst = POP form = arglst varlst = car(arglst) arglst = cdr(arglst) while( arglst != NIL ) # Evaluate the forms until we get a return. { # We check to see if we have encountered any labels. if( atom( car(arglst)) == T ) goto GOSTART PUSH(arglst) PUSH(varlst) PUSH(form) # NOTE: STPSH is one of the semi machne-dependent functions. It saves # the state of the interpreter at this point so it is dependent # on how the recursion primitives are implemented. call stpsh( rtrvsp()) areg = car(arglst) iv = eval() call stpop form = POP varlst = POP arglst = POP GOSTART arglst = cdr(arglst) #... otherwise go to the next form. } areg = varlst call UNBIND # If a RETURN never gets exectued then return NIL. prog = NIL RETURN_VALUE(NIL) # This section should never get exectuted in the normal flow of control. # But only if a jump from a RETURN is executed. if( .false. ) { RETURNSTOP continue # We need to POP what was PUSHed. form = POP varlst = POP arglst = POP areg = varlst call UNBIND val = rval # RETURN put the value in val. prog = val RETURN_VALUE(val) } # This block is similar to the one above except that it implements the GO. if( .false. ) { GOSTOP continue # POP what was PUSHed. form = POP varlst = POP arglst = POP # We search for the label from the top of the form. arglst = cdr(form) while( car(arglst) != gval & arglst != NIL ) arglst = cdr(arglst) # If we can't find the label in the currently executing PROG # then we jump to GOSTOP and restore the context of the next # higher level PROG, if there was one. if( arglst == NIL ) { areg = cons( gval, NIL) call go } else goto GOSTART } end #-t- prog 2570 ascii 15-Jan-84 13:58:18 #-h- psha 90 ascii 15-Jan-84 13:58:18 subroutine psha(i) include lspcm LISPVAL i dsp = dsp + 1 dstack(dsp) = i return end #-t- psha 90 ascii 15-Jan-84 13:58:18 #-h- ptprp 684 ascii 15-Jan-84 13:58:19 ### PtPrp Add/replace a PROPERTY on the property list. LISPVAL function ptprp() include lspcm LISPVAL val, prp, pp, plst, atm LISPVAL SYMBOLP integer n atm = areg val = breg prp = creg ifdef( CHECK_ARGUMENTS ) if( SYMBOLP(atm) == NIL | SYMBOLP(prp) == NIL ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef plst = cdr(atm) if( plst == NIL ) { RPLACD( atm, cons( prp, cons( val, NIL))) return(prp) } while( plst != NIL & car(plst) != prp ) { pp = plst plst = cdr( cdr(plst)) } if( car(plst) == prp ) RPLACA( cdr(plst), val) else RPLACD( cdr(pp), cons( prp, cons( val, NIL))) ptprp = val if( prp == QVALUE ) RPLACA( atm, val) return end #-t- ptprp 684 ascii 15-Jan-84 13:58:19 #-h- putln 706 ascii 15-Jan-84 13:58:19 ### PutLn Output LISP string on specified channel. LISPVAL function putln() include lspcm filedes fd filedes gtent # function(s) integer i, len integer stget # function(s) LISPVAL chn, lspstr LISPVAL STRINGP # function(s) lspstr = areg chn = breg ifdef( CHECK_ARGUMENTS ) if( STRINGP(lspstr) == NIL & lspstr != NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } if( chn != NIL & car(chn) != QOCHANNEL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef if( chn == NIL ) fd = STDOUT else fd = gtent( cdr( chn)) if( lspstr == NIL ) return(NIL) else { i = 1 len = stget( lspstr, strbuf, i) call putlin( strbuf, fd) return(lspstr) } end #-t- putln 706 ascii 15-Jan-84 13:58:19 #-h- quot2 67 ascii 15-Jan-84 13:58:19 LISPVAL function quot2() include lspcm return( car(areg)) end #-t- quot2 67 ascii 15-Jan-84 13:58:19 #-h- ratom 2324 ascii 15-Jan-84 13:58:20 ### RAtom Read the next ATOM from the input stream. LISPVAL function ratom() include lspcm character tmpbuf(MAX_STRING) character newch, READCH, s(2) LISPVAL ok, numc LISPVAL p, gtval, var, eval integer i, chrcnt LISPVAL MAKSTRING, readn, INTERN ratom = NIL # Skip the blanks. repeat { newch = READCH() if( newch == NIL ) return(NIL) if( newch == ' ') next if( newch == COMMENTCHAR ) { icptr = 0 next } break } # Check for read MACROs if(newch == '?' | newch == '#' | newch == '$' | newch == '%' | newch == '^' | newch == '&' | newch == '*' | newch == '~') { s(1) = newch s(2) = EOS var = INTERN(newch) if( car(CAR_FIELD(var)) == qrmac ) { areg = cdr(CAR_FIELD(var)) PUSH(lsym) ratom = eval() lsym = POP return(ratom) } } if( newch == '(' ) { lsym = qlpar return(qlpar) } else if( newch == '[' ) { lsym = qlbrkt return(qlpar) } else if( newch == ')' ) { rsym = qrpar return(qrpar) } else if( newch == ']' ) { rsym = qrbrkt if( lsym != qlbrkt ) BACKSP else { rsym = NIL lsym = NIL } return(qrpar) } else if( newch == '.' ) return(qdot) else if( newch == QUOTESYMBOL ) return(qquote) # If it is OK and NOT a NUMBER, then it is the start of an atom. else if( ok(newch) == T & numc(newch) == NIL ) { chrcnt = 0 # The atom will consist of the following OK characters. while( ok(newch) == T ) { chrcnt = chrcnt + 1 # Put the character in the temporary buffer. tmpbuf(chrcnt) = newch newch = READCH() tmpbuf(chrcnt+1) = EOS } # Backspace so the next call to READ will catch the NOT OK character. BACKSP # INTERN the atom on the oblist. If it has already been INTERNed, # the INTERN will return the ATOM. return( INTERN(tmpbuf)) } # If it is the start of a NUMBER. else if( numc(newch) == T | newch == '+' | newch == '-' ) { # Backspace so the NUMBER reader will get it. BACKSP return( readn()) } # If it is a string else if( newch == '"' ) { chrcnt = 0 newch = READCH() # READCHaracters until the next '"'. while( newch != '"' ) { 100 chrcnt = chrcnt + 1 tmpbuf(chrcnt) = newch newch = READCH() tmpbuf(chrcnt+1) = EOS } newch = READCH() if( newch == '"' ) goto 100 else BACKSP return( MAKSTRING(tmpbuf)) } return end #-t- ratom 2324 ascii 15-Jan-84 13:58:20 #-h- rcdr 283 ascii 15-Jan-84 13:58:20 ### Rcdr Handle DOT notation. LISPVAL function rcdr() include lspcm LISPVAL read, ratom LISPVAL j, nxtatm ENTRY_POINT j = read() nxtatm = ratom() # The next thing had better be a right paren. if( nxtatm != qrpar ) { j = QERROR rerflg = T } rcdr = j RETURN_VALUE(j) end #-t- rcdr 283 ascii 15-Jan-84 13:58:20 #-h- rderr 268 ascii 15-Jan-84 13:58:21 LISPVAL function rderr() include lspcm LISPVAL arg LISPVAL mksbr external reade arg = areg if( arg == NIL ) call setvl( qread, cons( qsubr, cons( mksbr(READSEG), mksbr(readfn)))) else call setvl( qread, cons( qsubr, mksbr( addrs(reade)))) return(arg) end #-t- rderr 268 ascii 15-Jan-84 13:58:21 #-h- read 653 ascii 15-Jan-84 13:58:21 ### Read The basic LISP "read" function. LISPVAL function read() include lspcm LISPVAL ratom, rhead, jcall LISPVAL j ENTRY_POINT # RATOM is the LISP scanner. There are special ATOMs for { (, ), ', . }. j = ratom() # Each of the subparts of the READ function check for quoted s-exprs. if( j == qquote ) { j = jcall(readfn) j = cons( quote, cons( j, NIL)) } else if( j == qlpar ) j = rhead() # It may be a long time before the user actually notices this error, # but when he does it will help him find exactly where the dot context # error is. else if( j == qrpar | j == qdot ) { j = QERROR rerflg = T } read = j RETURN_VALUE(j) end #-t- read 653 ascii 15-Jan-84 13:58:21 #-h- reade 528 ascii 15-Jan-84 13:58:22 ### ReadE Part of LISP "read" function. LISPVAL function reade() include lspcm LISPVAL j, err, jcall LISPVAL dmemb, brkp LISPVAL read character temp, READCH ENTRY_POINT LOAD_SEGMENT_IF_NECESSARY( READSEG ) rerflg = NIL j = jcall(readfn) if( rsym == qrbrkt & lsym != qlbrkt ) temp = READCH() if(rerflg) { LOAD_SEGMENT_IF_NECESSARY( PRINTSEG ) areg = j j = jcall(printf) TERPRI call remark( "? Error in read." ) reade = brkp() RETURN_VALUE(reade) } else { reade = j RETURN_VALUE(reade) } return end #-t- reade 528 ascii 15-Jan-84 13:58:22 #-h- readh 1633 ascii 15-Jan-84 13:58:22 ### Readh Read input lines, returning one character at a time. LISPVAL function readh() # The ' ' put on the front and back of every line are used to ensure that # back-spacing at least two spaces will always be possible. include lspcm character c integer i, len, rtbl(129) integer getlin, prompt # function(s) string uprmt ">" # This is the read table which establishes equivalence between characters. data rtbl / NUL, ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ' ', ESC, FS, GS, RS, US, ' ', '!', '"', '#', '$', '%', '&', '@'', '(', ')', '*', '+', ',', '-', '.', '/', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9', ':', ';', '<', '=', '>', '?', '@@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', '(', '\', ')', '^', '_', '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', '{', '|', '}', '~', DEL, 128/ if( icptr == 0 ) { if( inpstk(inplvl) == STDIN ) len = prompt( rprmt, icbuf, inpstk(inplvl)) else len = getlin( icbuf, inpstk(inplvl)) if( len == EOF ) return(NIL) call strcpy( uprmt, rprmt) icptr = 1 return(' ') } if( icptr > len ) { icptr = 0 return(' ') } c = icbuf(icptr) icptr = icptr + 1 if( c == NEWLINE | c == EOS ) c = ' ' c = rtbl( c + 1 ) return(c) end #-t- readh 1633 ascii 15-Jan-84 13:58:22 #-h- readn 453 ascii 15-Jan-84 13:58:23 ### ReadN Read numbers (using FORTRAN formatter) LISPVAL function readn() include lspcm character newch, READCH integer i character tbuf(20) LISPVAL numc LISPVAL mknum real x, preal newch = READCH() i = 1 while( numc(newch) == T | newch == '.' | newch == 'E' | newch == 'e' | newch == '+' | newch == '-' ) { tbuf(i) = newch i = i + 1 newch = READCH() } BACKSP call sfill( tbuf, i, 20, ' ') x = preal(tbuf) return( mknum(x)) end #-t- readn 453 ascii 15-Jan-84 13:58:23 #-h- retrn 252 ascii 15-Jan-84 13:58:23 integer function retrn() include lspcm external prog retrn = areg # Simply put the value some place where PROG will know where to # to look for it and then.. rval = retrn call jctxt call jmp( prog, rlabl, progsp) # ... leap back into the PROG. end #-t- retrn 252 ascii 15-Jan-84 13:58:23 #-h- rgpop 124 ascii 15-Jan-84 13:58:23 subroutine rgpop # RGPOP pops all the registers. include lspcm ereg = POP dreg = POP creg = POP breg = POP areg = POP end #-t- rgpop 124 ascii 15-Jan-84 13:58:23 #-h- rgpsh 144 ascii 15-Jan-84 13:58:24 ### RgPsh Push the five LISP argument registers. subroutine rgpsh include lspcm PUSH(areg) PUSH(breg) PUSH(creg) PUSH(dreg) PUSH(ereg) end #-t- rgpsh 144 ascii 15-Jan-84 13:58:24 #-h- rhead 851 ascii 15-Jan-84 13:58:24 ### RHead Read the first element of a non-atomic LISP s-expr. LISPVAL function rhead() include lspcm LISPVAL ratom, read, rtail, jcall LISPVAL j, ele1, ele2 ENTRY_POINT PUSH(lsym) j = ratom() # Again checking for quoted s-exprs. if( j == qquote ) { j = read() lsym = POP PUSH(lsym) j = cons( quote, cons( j, NIL)) } if( j == qrpar ) j = NIL # "( )" is equivalent to NIL else if( j == qlpar ) { ele1 = jcall(rheadf) lsym = POP PUSH(ele1) ele2 = rtail() # Get the rest of the list. ele1 = POP PUSH(lsym) j = cons( ele1, ele2) } # Again we are burying the error deep in the list structure. else if( j == qdot ) { j = QERROR rerflg = T } else { # The first element was ATOMic or quoted; just get the rest. PUSH(j) ele2 = rtail() ele1 = POP j = cons( ele1, ele2) } rhead = j lsym = POP RETURN_VALUE(j) end #-t- rhead 851 ascii 15-Jan-84 13:58:24 #-h- rlin2 408 ascii 15-Jan-84 13:58:25 ### Rlin2 Interface to "rolin" from LISP. LISPVAL function rlin2() include lspcm character fil(FILENAMESIZE) integer i integer stget # function(s) LISPVAL lspstr LISPVAL rolin, STRINGP # function(s) lspstr = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(lspstr) == NIL ) { call errlg( ARGUMENT_ERROR, RESTART_LISP) return(QERROR) } enddef i = 1 i = stget( lspstr, fil, i) return(rolin(fil)) end #-t- rlin2 408 ascii 15-Jan-84 13:58:25 #-h- rlout 3124 ascii 15-Jan-84 13:58:25 ### RlOut Roll out the current state of LISP as seen from toplevel. ### All rolled-out files should be rolled-in from toplevel. LISPVAL function rlout() # The function ROLLIN (rolin) should be examined for better comments # on the structure of the rollout file. include lspcm character fname(FILENAMESIZE) character chget # function(s) filedes fd filedes create # function(s) integer i, junk, n, p, status integer stget, writef # function(s) integer usedwd # This is the last used word in the LISTS array. LISPVAL gc, gcs, STRINGP LISPVAL control(ROLLOUT_BLOCK_SIZE) LISPVAL fstr string wrferr "? WRITEF error in ROLLOUT." fstr = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(fstr) == NIL ) { call errlg( ARGUMENT_ERROR, RESTART_LISP) return(QERROR) } enddef # Change the LISP string into a tools string. i = 1 junk = stget( fstr, fname, i) fd = create( fname, WRITE) if( fd == ERR ) { call errlg( IO_ERROR, RESTART_LISP) return(QERROR) } # The first thing which has to be done is to collect and # compress all the garbage. press = YES # Turn the compressor on. i = gc() i = gcs() press = NO # Turn the compressor back off. control(1) = nodect control(2) = av control(3) = stptr control(4) = ayptr status = writef( control, ROLLOUT_BLOCK_SIZE * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) status = writef( oblist, oblen * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) status = writef( symtbl, ROLLOUT_BLOCK_SIZE * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) usedwd = LAST_NODE - nodect * 3 + 1 for( i = INUM + 1 ; i <= usedwd ; i = i + ROLLOUT_BLOCK_SIZE ) { status = writef( lists(i), min0( usedwd - i + 1, ROLLOUT_BLOCK_SIZE) * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) } # Rollout the arrays. status = writef( arrays, 6 * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) p = 7 repeat { n = arrays( p + 1) if( arrays(p) != 1 ) { status = writef( NO, 1, fd) if( status == ERR | status == EOF ) call error(wrferr) status = writef( arrays(p), 4 * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) p = p + n } else { status = writef( YES, 1, fd) if( status == ERR | status == EOF ) call error(wrferr) status = writef( arrays(p), 2 * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) for( i = p + 2 ; i <= p + n - 1 ; i = i + ROLLOUT_BLOCK_SIZE ) { status = writef( arrays(i), min0( p + n - i, ROLLOUT_BLOCK_SIZE) * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(wrferr) } p = p + n } } until( p == ARRAY_SPACE ) for( i = 1 ; i <= stptr ; i = i + ROLLOUT_BLOCK_SIZE ) { status = writef( strngs(i), min0( stptr - i + 1, ROLLOUT_BLOCK_SIZE), fd) if( status == ERR | status == EOF ) call error(wrferr) } call close(fd) return(T) end #-t- rlout 3124 ascii 15-Jan-84 13:58:25 #-h- rmprp 690 ascii 15-Jan-84 13:58:26 ### RmPrp Remove a PROPERTY from the property list. ### If the property had a value return it, else return ### the third parameter. LISPVAL function rmprp() include lspcm LISPVAL plst, prp, atm, prlst LISPVAL SYMBOLP LISPVAL rtn atm = areg prp = breg rtn = creg ifdef( CHECK_ARGUMENTS ) if( SYMBOLP(atm) == NIL | SYMBOLP(prp) == NIL ) { call errlg( ARGUMENT_ERROR, ANYTHING) return(QERROR) } enddef if( prp == QVALUE ) return( car(atm)) plst = cdr(atm) prlst = NIL while( plst != NIL & car(plst) != prp ) { prlst = plst plst = cdr( cdr(plst)) } if( plst == NIL ) rmprp = rtn else { rmprp = car( cdr(plst)) RPLACD( cdr(prlst), cdr( cdr(plst))) } return end #-t- rmprp 690 ascii 15-Jan-84 13:58:26 #-h- rndom 359 ascii 15-Jan-84 13:58:26 ### Rndom Returns a random number 0 <= n < 1. LISPVAL function rndom() include lspcm integer now(7), seed LISPVAL NUMBERP LISPVAL mknum, i real numvl, ran i = areg if( NUMBERP(i) == T ) # Re-seed with i. seed = ifix( numvl(i)) else if( i != NIL ) # Re-seed with the time. { call getnow(now) seed = now(7) } return( mknum( ran( seed))) end #-t- rndom 359 ascii 15-Jan-84 13:58:26 #-h- rolin 3540 ascii 15-Jan-84 13:58:27 ### Rolin Roll-in a previously rolled-out LISP. LISPVAL function rolin(fil) include lspcm character fil(ARB), nam(FILENAMESIZE), path(FILENAMESIZE), valid character chget # function(s) filedes fd filedes open # function(s) integer usedwd # The last word used in the LISTS array integer i, n, p, status integer loccom, readf # function(s) integer control(ROLLOUT_BLOCK_SIZE) LISPVAL STRINGP string rdferr "? READF error in ROLLIN." string suffix ROLLIN_SUFFIX # We are making an assumptions here that there will never be # any more the ROLLOUT_BLOCK_SIZE controlling variables. call impath(path) if( loccom( fil, path, suffix, nam) == ERR ) return(NIL) fd = open( nam, READ) if( fd == ERR ) return(NIL) # As you will notice, none of the errors from readf are returned # to the user. Once you have started rolling in, that's it. # Get the sizing parameters. status = readf( control, ROLLOUT_BLOCK_SIZE * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) nodect = control(1) av = control(2) stptr = control(3) ayptr = control(4) # Get the OBLIST status = readf( oblist, oblen * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) # Get all those internal LISP atoms that the interpreter uses. status = readf( symtbl, ROLLOUT_BLOCK_SIZE * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) # Compute where the last node was at rollout. usedwd = LAST_NODE - nodect * 3 + 1 for( i = INUM + 1 ; i <= usedwd ; i = i + ROLLOUT_BLOCK_SIZE ) { status = readf( lists(i), min0( usedwd - i + 1, ROLLOUT_BLOCK_SIZE) * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) } # Recreate the free node list. lptr = usedwd + 2 for( i = usedwd + 2 ; i <= LAST_NODE - 3 ; i = i + 3 ) { CAR_FIELD(i) = i + 3 AUX_FIELD(i) = FREE_BIT } CAR_FIELD(i) = NIL # The first thing is the list head of free storage. It is a constant. status = readf( arrays, 6 * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) # Then we start wlaking through the array space just like we were # doing garbage collection. p = 7 repeat { # Each block of storage is preceded by a character telling # us whether the next block was allocated or not. status = readf( valid, 1, fd) if( status == ERR | status == EOF ) call error(rdferr) # For empty blocks all we need are the FLINK and BLINK fields. if( valid == NO ) status = readf( arrays(p), 4 * CHAR_PER_INT, fd) # For allocated blocks the next record is just the SIZE and TAG fields else status = readf( arrays(p), 2 * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) # In either case we have the size n = arrays( p + 1) if( valid == NO ) p = p + n else { # For allocated arrays we simply rollin the remainder of the data # in the array. for( i = p + 2 ; i <= p + n - 1 ; i = i + ROLLOUT_BLOCK_SIZE ) { status = readf( arrays(i), min0( p + n - i, ROLLOUT_BLOCK_SIZE) * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) } p = p + n } } until( p == ARRAY_SPACE ) # The STRING_SPACE for( i = 1 ; i <= stptr ; i = i + ROLLOUT_BLOCK_SIZE ) { status = readf( strngs(i), min0( stptr - i + 1, ROLLOUT_BLOCK_SIZE) * CHAR_PER_INT, fd) if( status == ERR | status == EOF ) call error(rdferr) } call close(fd) return(T) end #-t- rolin 3540 ascii 15-Jan-84 13:58:27 #-h- rpla2 204 ascii 15-Jan-84 13:58:27 LISPVAL function rpla2() include lspcm LISPVAL atom LISPVAL i, j i = areg j = breg if( atom(i) == T ) { rpla2 = QERROR call errlg( ARGUMENT_ERROR, ANYTHING) } else rpla2 = rplaa( i, j) end #-t- rpla2 204 ascii 15-Jan-84 13:58:27 #-h- rplaa 84 ascii 15-Jan-84 13:58:28 function rplaa( i, n) include lspcm LISPVAL i, n DEPOSIT( n, i) return(i) end #-t- rplaa 84 ascii 15-Jan-84 13:58:28 #-h- rplad 89 ascii 15-Jan-84 13:58:28 function rplad( i, n) include lspcm LISPVAL i, n DEPOSIT( n, i + 1 ) return(i) end #-t- rplad 89 ascii 15-Jan-84 13:58:28 #-h- rpld2 203 ascii 15-Jan-84 13:58:28 LISPVAL function rpld2() include lspcm LISPVAL i, j LISPVAL atom i = areg j = breg if( atom(i) == T ) { rpld2 = QERROR call errlg( ARGUMENT_ERROR, ANYTHING) } else rpld2 = rplad( i, j) end #-t- rpld2 203 ascii 15-Jan-84 13:58:28 #-h- rtail 757 ascii 15-Jan-84 13:58:29 ### RTail Read the tail of an s-expr. LISPVAL function rtail() include lspcm LISPVAL ratom, read, rhead, rcdr, jcall LISPVAL j, ele1, ele2 ENTRY_POINT PUSH(lsym) j = ratom() # Keep on the lookout for quoted s-exprs. if( j == qquote ) { j = read() lsym = POP PUSH(lsym) j = cons( quote, cons( j, NIL)) } if( j == qlpar ) # The next expression is a list. { ele1 = rhead() lsym = POP PUSH(ele1) ele2 = jcall(rtailf) ele1 = POP PUSH(lsym) j = cons( ele1, ele2) } else if( j == qdot ) j = rcdr() # We are in dot notation. else if( j == qrpar ) j = NIL # We got to the end of the list. else { PUSH(j) # We read an atom. ele2 = jcall(rtailf) ele1 = POP j = cons( ele1, ele2) } lsym = POP rtail = j RETURN_VALUE(j) end #-t- rtail 757 ascii 15-Jan-84 13:58:29 #-h- sbstr 702 ascii 15-Jan-84 13:58:29 ### SbStr Take a substring. LISPVAL function sbstr() include lspcm integer strln integer i, k, j LISPVAL p LISPVAL istrg, heap LISPVAL STRINGP, NUMBERP real numvl, x, y istrg = areg x = numvl(breg) y = numvl(creg) if( STRINGP(istrg) == NIL | NUMBERP(breg) == NIL | NUMBERP(creg) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } else if( x < 1. | y < 1. ) { call errlg( STRING_ERROR, STRING_VALUE) return(QERROR) } i = ifix(x) j = ifix(y) k = strln(istrg) p = heap() DEPOSIT( STRING_BIT, p - 1 ) if( i > k ) { DEPOSIT( 0, p) DEPOSIT( 1, p + 1 ) } else { DEPOSIT( EXAMINE( istrg + 1 ) + i - 1, p + 1 ) DEPOSIT( min0( j, k - i + 1 ), p) } return(p) end #-t- sbstr 702 ascii 15-Jan-84 13:58:29 #-h- set 137 ascii 15-Jan-84 13:58:30 ### Set Implement the "set" function. LISPVAL function set() include lspcm LISPVAL PUTPROP creg = QVALUE return( PUTPROP()) end #-t- set 137 ascii 15-Jan-84 13:58:30 #-h- setq 284 ascii 15-Jan-84 13:58:30 ### Setq Implement the "setq" function. LISPVAL function setq() include lspcm LISPVAL val, eval LISPVAL atm LISPVAL PUTPROP ENTRY_POINT PUSH( car(areg)) areg = car( cdr(areg)) val = eval() atm = POP areg = atm breg = val creg = QVALUE setq = PUTPROP() RETURN_VALUE(setq) end #-t- setq 284 ascii 15-Jan-84 13:58:30 #-h- setvl 178 ascii 15-Jan-84 13:58:30 ### SetVl Set the value of a symbol. subroutine setvl( i, n) include lspcm LISPVAL i, junk, n LISPVAL PUTPROP areg = i breg = n creg = QVALUE junk = PUTPROP() return end #-t- setvl 178 ascii 15-Jan-84 13:58:30 #-h- sevl 241 ascii 15-Jan-84 13:58:31 LISPVAL function sevl() include lspcm LISPVAL val, arglst, eval ENTRY_POINT sevl = NIL arglst = areg while( arglst != NIL ) { PUSH(arglst) areg = car(arglst) val = eval() arglst = cdr(POP) } sevl = val RETURN_VALUE(val) end #-t- sevl 241 ascii 15-Jan-84 13:58:31 #-h- sfill 177 ascii 15-Jan-84 13:58:31 ### SFill Fill buf(is):buf(if) with 'c'. subroutine sfill( buf, is, if, c) character buf(ARB), c integer is, if for( i = is ; i <= if ; i = i + 1 ) buf(i) = c return end #-t- sfill 177 ascii 15-Jan-84 13:58:31 #-h- shwfr 651 ascii 15-Jan-84 13:58:32 ### ShwFr Display the context stack. LISPVAL function shwfr() include lspcm integer i integer istart, istop LISPVAL arg1, arg2 real numvl arg1 = areg # These two arguments designate how far back up the context arg2 = breg # stack to go and how many contexts we want to print out. # The default is 1 1. if( arg1 == NIL ) { istart = cptr - 2 istop = istart } else { istart = cptr - 1 - numvl(arg1) if( arg2 == NIL ) istop = istart # The default is to print only 1. else istop = istart + numvl(arg2) - 1 } do i = max0( istart, 1), min0( istop, CONTEXT_STACK_SIZE) { areg = cstk(i) call print TERPRI } return(NIL) end #-t- shwfr 651 ascii 15-Jan-84 13:58:32 #-h- shwst 232 ascii 15-Jan-84 13:58:32 ### ShwSt Display the CAR of each element of the traceback context stack. LISPVAL function shwst() include lspcm integer i for( i = 1 ; i < cptr ; i = i + 1 ) { areg = car( cstk(i)) call print TERPRI } return(NIL) end #-t- shwst 232 ascii 15-Jan-84 13:58:32 #-h- sinx 288 ascii 15-Jan-84 13:58:32 ### Sinx Return the sine. LISPVAL function sinx() include lspcm LISPVAL NUMBERP LISPVAL mknum, i real numvl, sin i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( sin( numvl(i)))) end #-t- sinx 288 ascii 15-Jan-84 13:58:32 #-h- sleng 325 ascii 15-Jan-84 13:58:33 ### SLeng Return the length of a LISP string. LISPVAL function sleng() include lspcm LISPVAL istr, mknum LISPVAL STRINGP integer strln istr = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(istr) == NIL ) { call errlg( ARGUMENT_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( float( strln(istr)))) end #-t- sleng 325 ascii 15-Jan-84 13:58:33 #-h- smakfn 291 ascii 15-Jan-84 13:58:33 LISPVAL function smakfn( segnum, buf, type, adrs) include lspcm character buf(ARB) integer segnum LISPVAL type LISPVAL atm, ent LISPVAL INTERN ADDRESS adrs LISPVAL mksbr atm = INTERN(buf) ent = cons( mksbr(segnum), mksbr(adrs)) call setvl( atm, cons( type, ent)) return(atm) end #-t- smakfn 291 ascii 15-Jan-84 13:58:33 #-h- sqrtx 368 ascii 15-Jan-84 13:58:34 ### Sqrt Return the square root of a number. LISPVAL function sqrtx() include lspcm LISPVAL i LISPVAL NUMBERP LISPVAL mknum real r real numvl, qsrt i = areg repeat # Not really... { if( NUMBERP(i) == NIL ) break r = numvl(i) if( r < 0.0 ) break sqrtx = mknum( sqrt(r)) return } call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) end #-t- sqrtx 368 ascii 15-Jan-84 13:58:34 #-h- stats 579 ascii 15-Jan-84 13:58:34 ### Stats Return space utilization statistics as a list. LISPVAL function stats() # The returned list contains: # number of nodes left # number of chacters of string space left # size of the largest array block. include lspcm include lspem LISPVAL mknum integer maxa, p p = ( arrays( av + 3 )) maxa = 0 repeat { if( arrays( p + 1 ) > maxa ) maxa = arrays( p + 1 ) p = arrays( p + 3 ) } until( p == arrays( av + 3 )) stats = cons( mknum( float(nodect)), cons( mknum( float(maxa)), cons( mknum( float( STRING_SPACE - stptr )), NIL))) return end #-t- stats 579 ascii 15-Jan-84 13:58:34 #-h- stcom 601 ascii 15-Jan-84 13:58:34 ### StCom Compare two LISP strings. integer function stcom( jstr, kstr) include lspcm character kchr, jchr character chget # function(s) integer klen, jlen integer i, len, strln LISPVAL kstr, jstr jlen = strln(jstr) klen = strln(kstr) len = min0( jlen, klen) stcom = 1 jchr = chget( jstr, 1) kchr = chget( kstr, 1) for( i = 1 ; i <= len - 1 & jchr == kchr ; i = i + 1 ) { jchr = chget( jstr, i + 1 ) kchr = chget( kstr, i + 1 ) } if( jchr == kchr ) { if( jlen > klen ) return(-1) else if( jlen < klen ) return else return(0) } else if( jchr < kchr ) return(-1) end #-t- stcom 601 ascii 15-Jan-84 13:58:34 #-h- stget 355 ascii 15-Jan-84 13:58:35 ### StGet Gather a LISP string into a RatFor string, returning length. integer function stget( lspstr, ratstr, ndx) character ratstr(ARB) character chget integer i, len, ndx integer strln LISPVAL lspstr len = strln(lspstr) for( i = 1 ; i <= len ; i = i + 1 ) { ratstr(ndx) = chget( lspstr, i) ndx = ndx + 1 } ratstr(ndx) = EOS return(len) end #-t- stget 355 ascii 15-Jan-84 13:58:35 #-h- store 1675 ascii 15-Jan-84 13:58:35 ### Store Store into an ARRAY. LISPVAL function store() include lspcm include lspem LISPVAL arglst LISPVAL eval, list LISPVAL arry, dlst, val LISPVAL subrp integer p, gtent, ndim, dim, ele integer index integer min, max real numvl integer NUMBERP ENTRY_POINT arglst = areg # The arglist should be of the form((array ind1 ind2) val)) store = NIL PUSH(arglst) areg = car( car(arglst)) # Get the array. arry = eval() arglst = POP PUSH(arry) PUSH(arglst) areg = cdr( car(arglst)) # Get which element to access. dlst = list() arglst = POP PUSH(dlst) areg = car( cdr(arglst)) # Get the value to put in the cell. val = eval() dlst = POP arry = POP if( car(arry) != qarray | subrp( cdr(arry)) == NIL ) # Check array header { call errlg( ARRAY_SPEC_ERROR, ANYTHING) store = QERROR RETURN_VALUE(QERROR) } p = gtent( cdr(arry)) # Get the start of the block. ndim = arrays(p) dim = 0 ele = 0 while( dlst != NIL ) { dim = dim + 1 if( dim > ndim ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) store = QERROR RETURN_VALUE(QERROR) } if( NUMBERP( car(dlst)) == NIL ) { call errlg( ARRAY_SPEC_ERROR, ANYTHING) store = QERROR RETURN_VALUE(QERROR) } index = numvl( car(dlst)) min = arrays( p + 2 * dim - 1 ) max = arrays( p + 2 * dim ) if( index < min | index > max ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) store = QERROR RETURN_VALUE(QERROR) } ele = ele * ( max - min + 1 ) + ( index - min ) dlst = cdr(dlst) } if( dim != ndim ) { call errlg( SUBSCRIPT_ERROR, ANYTHING) store = QERROR RETURN_VALUE(QERROR) } ele = ele + 1 arrays( p + ndim * 2 + ele ) = val store = val RETURN_VALUE(val) end #-t- store 1675 ascii 15-Jan-84 13:58:35 #-h- stpop 62 ascii 15-Jan-84 13:58:36 subroutine stpop include lspcm prptr = prptr - 4 return end #-t- stpop 62 ascii 15-Jan-84 13:58:36 #-h- stpsh 481 ascii 15-Jan-84 13:58:36 subroutine stpsh(ssp) # We use a separate stack for the progs. We have to because PROGs # don't always follow the recursive flow of control. include lspcm LISPVAL getvl integer ssp if( prptr > PROG_STACK_SIZE ) { call remark( "? Too many progs." ) call brkp call toplv } prstk(prptr) = cptr # Save the context stack for EVAL. prstk( prptr + 1 ) = ssp prstk( prptr + 2 ) = dsp prstk( prptr + 3 ) = getvl(QBINDING) # Save the binding context. prptr = prptr + 4 return end #-t- stpsh 481 ascii 15-Jan-84 13:58:36 #-h- str2 87 ascii 15-Jan-84 13:58:37 LISPVAL function str2() include lspcm LISPVAL STRINGP return( STRINGP(areg)) end #-t- str2 87 ascii 15-Jan-84 13:58:37 #-h- strgp 233 ascii 15-Jan-84 13:58:37 ### Strgp Determine whether or not the argument is a string. PREDICATE strgp(s) include lspcm LISPVAL s if( s == NIL | s == T ) strgp = NIL else if( EXAMINE( s - 1 ) == STRING_BIT ) strgp = T else strgp = NIL return end #-t- strgp 233 ascii 15-Jan-84 13:58:37 #-h- strln 188 ascii 15-Jan-84 13:58:38 ### StrLn Return the length of a LISP string. LISPVAL function strln(s) include lspcm LISPVAL s LISPVAL STRINGP if( STRINGP(s) == NIL ) return(0) else return( EXAMINE(s)) end #-t- strln 188 ascii 15-Jan-84 13:58:38 #-h- sub1 300 ascii 15-Jan-84 13:58:38 ### Sub1 Subract 1 from a number. LISPVAL function sub1() include lspcm LISPVAL i, mknum LISPVAL NUMBERP real numvl i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef ab = numvl(i) return( mknum( ab - 1.0 )) end #-t- sub1 300 ascii 15-Jan-84 13:58:38 #-h- subrp 239 ascii 15-Jan-84 13:58:39 ### SubrP Determine whether or not the argument is a SUBR. PREDICATE subrp(ent) include lspcm LISPVAL ent if( ent == NIL | ent == T ) subrp = NIL else if( EXAMINE( ent - 1 ) == SUBR_BIT ) subrp = T else subrp = NIL return end #-t- subrp 239 ascii 15-Jan-84 13:58:39 #-h- sym2 79 ascii 15-Jan-84 13:58:39 PREDICATE sym2() include lspcm LISPVAL SYMBOLP return( SYMBOLP(areg)) end #-t- sym2 79 ascii 15-Jan-84 13:58:39 #-h- symbp 232 ascii 15-Jan-84 13:58:39 ### SymbP Determine whether or not the argument is a SYMBOL. PREDICATE symbp(i) include lspcm LISPVAL i if( i == NIL | i == T ) symbp = NIL else if( EXAMINE( i - 1 ) == SYMBOL_BIT ) symbp = T else symbp = NIL return end #-t- symbp 232 ascii 15-Jan-84 13:58:39 #-h- tanx 303 ascii 15-Jan-84 13:58:40 ### Tanx Return the tangent of a number. LISPVAL function tanx() include lspcm LISPVAL NUMBERP LISPVAL mknum, i real numvl, tan i = areg ifdef( CHECK_ARGUMENTS ) if( NUMBERP(i) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef return( mknum( tan( numvl(i)))) end #-t- tanx 303 ascii 15-Jan-84 13:58:40 #-h- terpi 224 ascii 15-Jan-84 13:58:40 ### TerPi Output a NEWLINE. LISPVAL function terpi() include lspcm integer i prbuf(pcptr+1) = '@n' prbuf(pcptr+2) = EOS call putlin( prbuf, output) call sfill( prbuf, 1, LINE_LENGTH, ' ') pcptr = 0 return(qblnk) end #-t- terpi 224 ascii 15-Jan-84 13:58:40 #-h- times 431 ascii 15-Jan-84 13:58:40 ### Times Implement the "times" function. LISPVAL function times() include lspcm LISPVAL mknum, i, arglst LISPVAL NUMBERP real numvl, prod arglst = areg prod = 1.0 while( arglst != NIL ) { ifdef( CHECK_ARGUMENTS ) if( NUMBERP( car(arglst)) == NIL ) { call errlg( ARITH_ERROR, NUMERIC_VALUE) return(QERROR) } enddef prod = prod * numvl( car(arglst)) arglst = cdr(arglst) } return( mknum(prod)) end #-t- times 431 ascii 15-Jan-84 13:58:40 #-h- toplv 272 ascii 15-Jan-84 13:58:41 ### TopLv Clear the recursion stack and jump to toplevel. LISPVAL function toplv() include lspcm external main dsp = 0 output = defout inpstk(inplvl) = defin level = 0 cptr = 1 call flshr call flshp call unwnd(NIL) toplv = NIL call jmp( main, TOPOFLISP, savedsp) end #-t- toplv 272 ascii 15-Jan-84 13:58:41 #-h- tyo 150 ascii 15-Jan-84 13:58:41 ### TyO Output a number. LISPVAL function tyo() include lspcm LISPVAL arg real numvl arg = areg PRINTCH( ifix( numvl(arg))) return(arg) end #-t- tyo 150 ascii 15-Jan-84 13:58:41 #-h- uarry 398 ascii 15-Jan-84 13:58:42 ### UArry Deallocate space for an array. LISPVAL function uarry() include lspcm include lspem LISPVAL arry LISPVAL subrp LISPVAL gtent arry = areg if( car(arry) != qarray ) # Check to make sure that it is a an array header. return(NIL) if( subrp( cdr(arry)) == NIL ) # Ensure a properly formed header. return(NIL) call free( gtent( cdr(arry))) call rplad( arry, NIL) return(T) end #-t- uarry 398 ascii 15-Jan-84 13:58:42 #-h- unbnd 901 ascii 15-Jan-84 13:58:42 ### Unbnd Unbind a list of variables. LISPVAL function unbnd() include lspcm LISPVAL varlst LISPVAL bdlst, cell LISPVAL getvl LISPVAL atom ENTRY_POINT varlst = areg bdlst = getvl(QBINDING) while( atom(varlst) == NIL ) { cell = car(bdlst) # NOTE: If the names of the elements in varlst don't match the one # in the binding context stack, there has been a very serious error. if( car(varlst) != car(cell)) { call errlg( SEVERE_ERROR, RESTART_LISP) call brkp unbnd = NIL RETURN_VALUE(NIL) } call setvl( car(varlst), cdr(cell)) varlst = cdr(varlst) bdlst = cdr(bdlst) } if( varlst != NIL ) { cell = car(bdlst) if( varlst != car(cell)) { call errlg( SEVERE_ERROR, RESTART_LISP) call brkp unbnd = NIL RETURN_VALUE(NIL) } call setvl( varlst, cdr(cell)) bdlst = cdr(bdlst) } call setvl( QBINDING, bdlst) unbnd = T RETURN_VALUE(T) end #-t- unbnd 901 ascii 15-Jan-84 13:58:42 #-h- unwnd 469 ascii 15-Jan-84 13:58:42 ### Unwnd Unwind the context binding stack. ### Used primarily for implementing GOs and RETURNs in PROGs. subroutine unwnd(envrn) include lspcm LISPVAL envrn # envrn is the point on the binding context stack # (i.e. the evironment) to which we want to return. LISPVAL bdlst, cell, getvl bdlst = getvl(QBINDING) while( bdlst != envrn ) { cell = car(bdlst) call setvl( car(cell), cdr(cell)) bdlst = cdr(bdlst) } call setvl( QBINDING, bdlst) return end #-t- unwnd 469 ascii 15-Jan-84 13:58:42 #-h- uprstr 388 ascii 15-Jan-84 13:58:43 ### UprStr Convert a string to uppercase. LISPVAL function uprstr() include lspcm integer i, len LISPVAL str LISPVAL MAKSTRING, stget, STRINGP # function(s) str = areg ifdef( CHECK_ARGUMENTS ) if( STRINGP(str) == NIL ) { call errlg( ARGUMENT_ERROR, STRING_VALUE) return(QERROR) } enddef i = 1 len = stget( str, strbuf, i) call upper(strbuf) return( MAKSTRING( strbuf)) end #-t- uprstr 388 ascii 15-Jan-84 13:58:43 #-h- wloop 805 ascii 15-Jan-84 13:58:43 ### WLoop A RatFor-style "while" loop. LISPVAL function wloop() include lspcm LISPVAL alst, arglst, cond, ival, iwhl LISPVAL eval # function(s) ENTRY_POINT wloop = NIL arglst = areg cond = car(arglst) # The condition for the WHILE loop is # first element of the form. PUSH(cond) PUSH(arglst) areg = cond iwhl = eval() arglst = cdr(POP) cond = POP while( iwhl != NIL ) { alst = arglst while( alst != NIL ) # EVALuate the rest of the forms # sequentially... { PUSH(alst) PUSH(cond) PUSH(arglst) areg = car(alst) ival = eval() arglst = POP cond = POP alst = POP alst = cdr(alst) } PUSH(cond) PUSH(arglst) PUSH(ival) areg = cond iwhl = eval() # ... and check the condition. ival = POP arglst = POP cond = POP } RETURN_VALUE(ival) end #-t- wloop 805 ascii 15-Jan-84 13:58:43 #-t- lisp.r 161312 ascii 15-Jan-84 14:27:56 #-h- lisps.ar 51839 ascii 15-Jan-84 14:28:13 #-h- adalir.lsp 2882 ascii 15-Jan-84 14:18:01 ; AdaLIR.lsp -- An implementation of Robert Firth's ``Universal Ada Language ; Issue Report Construction Kit'' from ACM SIGPLAN NOTICES ; Volume 15, Number 5, May 1980. ; Define the string lists. (setq A '( ( (one_of C) "unacceptable" ) "useless" ( (one_of C) "flawed" ) "semantically ill-defined" ( (one_of C) "non-orthogonal" ) ( "almost as bad as" (one_of P) ) )) (setq B '( "abstraction" "type composition" "efficiency" "tasking" ( "interface to" (one_of P) ) "generics" "procedure parameters" "overloading" "access to shared data" "i/o" "access allocation" "chipmunks" )) (setq C '( "fatally" "totally" "radically" "dangerously" "basically" "vitally" "critically" "unacceptably" "hopelessly" "unavoidably" )) (setq D '( "inflight programs" "data base management" "multiprocessor systems with shared store" "symbolic programming" "multiprocessor systems without shared store" "sauerkraut production control" "critical real-time applications" "multiprocessor systems with a little shared store" "online fruit bat tracking" "military command and control systems" "teaching programming" "building Ada support systems" "getting my next government contract" )) (setq E '( "adding" "removing" )) (setq F '( "user-defined assignment" "strong typing" "spinlocks" "scheduling primitives" "tasks as parameters to recursive generic type families" "finalise" "garbage collection" "types as parameters to recursive generic task families" "binary i/o" "task CLOCK attribute" "recursion" "based variables" "chipmunks" )) (setq P '( "FORTRAN" "PL/I" "CMS/2" "EDSAC machine code" )) ; ; Print a string, breaking lines at word boundaries. ; (defun print_it (string) (prog (c n s) (setq s (explode string)) (for (setq n 1) s (setq n (add1 n)) (setq c (car s)) (setq s (cdr s)) (cond ((equal c blank) (cond ((greaterp n 58) (terpri) (setq n 0)) ((equal n 1) (setq n 0)) (t (princ (get_pname c))))) (t (princ (get_pname c)))) ) (terpri) ) ) ; ; Return a random string from the specified list. ; (defun one_of (list) (prog (s) (setq s (nth (randomi (length list)) list)) (cond ((stringp s) (return s)) ((stringp (car s)) (return (concat (car s) " " (eval (cadr s))))) (t (return (concat (eval (car s)) " " (cadr s)))) ) ) ) ; ; Generate a single LIR. ; (defun gen_one () (concat "Ada as at present constituted is " (one_of A) " in the area of " (one_of B) ". This will " (one_of C) " impact its use in " (one_of D) ". The problem can be cured by " (one_of E) " " (one_of F) "." ) ) (defun run (n) (for nil (greaterp n 0) (setq n (sub1 n)) (print_it (gen_one)) (terpri) ) ) (random "seed") #-t- adalir.lsp 2882 ascii 15-Jan-84 14:18:01 #-h- cat.lsp 929 ascii 15-Jan-84 14:18:02 ;;; cant Print "Can't open" message and return to top level. (defun cant (file) (prog () (putlin (concat "Can't open file named ``" file "''.")) (terpri) (toplevel) ) ) ;;; first Like "car" except first(nil) => nil. (defun first (file_list) (cond ((null file_list) nil) (t (car file_list)) ) ) ;;; cat Concatenate & print a single file or a list of files. (defun cat (file_list) (prog (channel file) ; If the argument is a string, convert it into a list. (cond ((stringp file_list) (setq file_list (list file_list)))) ; Step through the list of files. (for t (setq file (first file_list)) (setq file_list (cdr file_list)) ; Open the file and copy it to STDOUT a line at a time. (cond ((setq channel (open file 'READ)) (while (putlin (getlin channel))) ) (t (cant file)) ) (close channel) ) (return t) ) ) #-t- cat.lsp 929 ascii 15-Jan-84 14:18:02 #-h- edit.lsp 35591 ascii 15-Jan-84 14:18:02 ; editor from bbn-lisp c. 1968 ; (transcribed by r. fateman for unix lisp, oct., 1977) ; (modified and enhanced by p. pifer, may, 1978) ; (corrected again by r. fateman for vax unix lisp, dec., 1978) ; (cleaned up, commented and compiled by j. foderaro, aug., 1979) ; ( ... fixed bug in ^ command) ; ; currently being modified by c. p. dolan for hack lisp ; fixed bug in (r ...) command ; fixed bug in the execution of macros with no paramters ; ; changed comment character from '!' to ';'. (dpm 16-dec-82) ; changed quote character from '@' to '''. (dpm 16-dec-82) ; folded to lowercase. (dpm 16-dec-82) ; ; the following is a list of all the commands which have been ; debugged and checked out for use with the hack lisp interpreter: ; ; ok -- ends the editing session ; e from -- makes a call to eval with form ; p -- prints the current expression with the ; current print level ; pp -- pretty prints the entire ce ; mark -- marks the current expression for reference later ; < -- returns to last last ce marked ; << -- same as < but erases the mark ; ^ -- returns to top level expression ; poff -- sets the printflag off ; pon -- sets the printflag on ; n -- n > 0 makes the nth expression of the ce the current expression ; n = 0 goes up one level ; (s var [cmnds]) -- sets var to the ce after executing the cmnds ; (r e1 e2) -- replaces e1 with e2 throughout the ce ; (e form) -- same as e form ; (n e1 e2 ... em) -- replaces the nth member of the ce with ; e1 e2 ... em ; (-n e1 e2 ... em) -- inserts e1 e2 ... em before the nth member of ; the ce ; (i n e1 e2 ... em) -- same as (n e1 e2 ... em) except that the ei's ; are evaluated first ; (n e1 e2 ... em) -- concatenates the ei's at the end of the ce ; (p n m) -- print the nth member of the ce to level m ; (pl n) -- set the print level to n ; (bi n m) -- inserts a left paren before the nth element of the ce ; and a right paren after the mth. for example: ; (a b (c d e) f g) --(bi 2 4)--> (a (b (c d e) f) g) ; (bo n) -- deletes the parentheses around the nth element of the ce. ; for example: ; (a b (c d e) f g) --(bo 2)--> (a b c d e f g) ; (li n) -- inserts a left paren before the nth element of the ce ; and adds a right paren at the enf of the ce. for example: ; (a b (c d e) f g) --(li 2)--> (a (b (c d e) f g)) ; (lo n) -- removes the left paren before the nth element of the ce, ; deleting the rest of the ce. for example: ; (a b (c d e) f g) --(lo 2)--> (a b c d e) ; (ri n m) -- insert a right paren after the mth element of the nth ; element of the ce. for example: ; (a (b c d e) f g) --(ri 2 3)--> (a (b c d) e f g) ; (ro n) -- removes the right paren from the nth element of the ce ; and places it at the end of the list for example: ; (a b (c d e) f g) --(ro 3)--> (a b (c d e f g)) ; (f pat) -- finds the 'pat' in the current expression if 'pat' ; is on the top level. ; (f pat n) -- finds the nth ocurrance of 'pat' in the expression ; (f pat n) -- finds the 'pat' in the current expression ; but assures that the edit chain will change ; (d name cmd1 cmd2 ...) -- defines a macro which when envoked by ; name, exectues the cmdi ; (d (name) varspec cmd1 cmd2...) -- defines a macro with paramters ; which are substituted before ; cmdi are execturted ; varspec has two forms: 1) var -for a sigle paramter ; 2) (var1 var2 ...) for several ; (m name cmd1 cmd2 ...) -- same a d but defines global macros ; or ; (m (name) varspec cmd1 cmd2 ...) ; (setq printflag t) ; print on by default (setq $$$printlevel 3) (setq maxlevel 100) (setq findflag nil) (setq supereditflg t)(setq printflag t)(setq edrptcnt nil) ; we need these functions for compatablity ; with franz lisp (define ( (def (lambda argl (prog () (set (car argl) (car (cdr argl))) (return (car argl)) )) ) (getd (lambda (f) (prog (type) (setq type (car (get f 'value))) (cond ((or (eq type 'subr) (eq type 'fsubr) (eq type 'lambda) (eq type 'label)) (return (get f 'value))) (t (return nil)) ))) ) (putd (lambda (f fn) (set f fn)) ) (bcdp (lambda (x) nil)) (errset (lambda x (eval (car x)))) (drain (lambda () (cond (t (flushread) (flushprint))))) (dtpr (lambda (x) (null (atom x)))) (err (lambda x (cond (x (print (car x))(terpri) (break) nil) (t (print 'call_to_err)(terpri) (break) nil))) ) )) (setq patom print) (setq not null) (cond ((null (eq (get 'pp 'value) 'unbound)) (setq $prpr pp)) (t(setq $prpr print))) ;--- remedit - removes all traces of the editor from the oblist. ; note that if the editor is compiled, the code space ; will not be reclaimed ; (def remedit (lambda nil (prog nil (mapc (function (lambda (x) (set x nil))) '(editmacros findflag supereditflg edrptcnt printflag $$$printlevel maxlevel)) (mapc (function (lambda (x) (putd x nil))) '(editf editv tconc eprint eprint1 printlevel dsubst editcoms edit1f edit2f edit2af edit4e editqf edit4e edit4f edit4f1 editnth bpnt bpnt0 subpair subpr ri ro li lo bi bo ldiff nthcdr attach edite editcom editdefault remedit)) (return 'gone)))) ;--- subst - a - newval ; - b : oldvall ; - c : string ; substitute a for b in c ; (def subst (lambda (a b c) (cond ((equal b c) a) ((atom c) c) (t (cons (subst a b (car c)) (subst a b (cdr c))))))) ;--- printlevel - x : new value ; set the $$$printlevel to x and return the old value ; [change this to prog1 ] ; (def printlevel (lambda (x) (prog (a) (setq a $$$printlevel) (setq $$$printlevel x) (return a)))) ;--- editf - funcname : name of function to edit ; - [cmds] : commands to apply right away ; this is the starting point in the editor. you specify the ; file you wish to edit and perhaps some initial commands to ; the editor. if the function is not machine coded you ; enter the editor. ; (def editf (lambda x (prog (a c) (setq a (getd (car x))) (cond ((or (null a) (bcdp a)) (return '(not editable)))) (putd (car x) (cdr (edite a (cdr x) nil))) (return (car x))) )) ;--- dsubst - x : newval ; - y : oldval ; - z : form ; directly substitutes all occurances of y in form z with x. ; it uses rplaca and does not copy the structure. ; (def dsubst (lambda (x y z) (cond ((dtpr z) (cond ((equal y (car z)) (rplaca z x)) (t (dsubst x y (car z)))) (dsubst x y (cdr z)) z ) (t z) ) )) ;--- editcoms -- used to execute a list of commands to the editor. ; (def editcoms (lambda (c) (mapc (function editcom) c))) ;---edit1f --implements numeric commands ; c-number ; l-current expression ; (def edit1f (lambda (c l) (cond ((equal c 0) (cond ((null (cdr l)) (err nil)) (t (cdr l)))) ; l is a list of current expresions ; the car of l is "the" ce ((greaterp c 0) (cond ((greaterp c (length (car l))) (err nil)) ; nthcdr assists in steping down the list (t (cons (car (nthcdr (sub1 c) (car l) )) l)))) ((greaterp (times c -1) (length (car l))) (err nil)) (t (cons (car (nthcdr (plus (length (car l)) c) (car l) )) l)) ))) ;---edit2f --implements commands which begin with a number ; calls edit2af ; c-the command ; (n e1 e2 ... em) ; (-n e1 e2 ... em) ; (def edit2f (lambda (c) (cond ((greaterp (car c) 0) ; if n > 0 (cond ((greaterp (car c) (length (car l))) (err nil)) (t (rplaca l (edit2af (sub1 (car c)) (car l) (cdr c) nil)))) ) ((or (equal (car c) 0) (null (cdr c)) (greaterp (times -1 (car c)) (length (car l)))) (err nil)) (t (rplaca l (edit2af (sub1 (times -1 (car c))) (car l) (cdr c) t))) ))) ;---edit2af --is called by edit2f for implementing the commands ; which start with a number ; n-is the number ; x-the expression to do the insert or replace in ; r-a list of expressions to put in ; d-a flag to signify insertion or deletetion ; (def edit2af (lambda (n x r d) (prog nil (cond ((null (equal n 0)) ; make sure we don't have 0 (rplacd (nthcdr (sub1 n) x) (nconc r (cond (d (nthcdr n x)) (t (nthcdr (add1 n) x ))))) ) ; does it ever reach this point since edit2f checks ; for n=0. (d (attach (car r) x) (rplacd x (nconc (cdr r) (cdr x)))) (r (rplaca x (car r)) (rplacd x (nconc (cdr r) (cdr x)))) (t (print (list 'aha x)) (rplaca x (cadr x)) (rplacd x (cddr x))) ) (return x) ))) ;--- edit4e --used to implement the pattern matching for search commands ; this function defines the pattern matching algorithm. ; x-pattern to find ; y-candidate expression ; (def edit4e (lambda (x y) (cond ((equal x y) t) ((atom x) (eq x '&)) ((atom y) nil) ((edit4e (car x) (car y)) (or (eq (cadr x) '_) (edit4e (cdr x) (cdr y))) ) ))) ;--- editqf --this function is used for the deep find command ; s-expression to find ; n-numeric which ocurrance of s to get ; 'n make sure that the edit chain changes ; (def editqf (lambda (s) (prog (q1) (return (cond ((setq q1 (member s (cdar l))) (setq l (cons q1 l))) (t (edit4f s 'n) (cond ((not (atom s)) (setq l (cons (caar l) l))) ) ) )) ))) ;--- edit4f --used to implement the find command ; s-expression to find ; n-flag ; numeric-ocurrance of s to get ; 'n-do not alow a find which will ; not change the edit chain ; (def edit4f (lambda (s n) (prog (ff ll x) ; this along with the strange code at the ; end of the function emplement find with ; imperative chain change. (setq ll (cond ((eq n 'n) (cons (caar l) l)) (t l))) (setq x (car ll)) (setq ff (cons nil nil)) ; we maintain the edit chain in ff (cond ((and n (not (numberp n))) (setq n 1))) lp (cond ((edit4f1 s x maxlevel) ; if edit4f1 finds the expr (setq l (nconc (car ff) ll)) ; then the edit chain to that (return (car l))) ; new ce is in car f ((null n) (err 'no_match)) ) lp1 (setq x (car ll)) ; this section of the code would ; seem to be dedicated to implementing ; the 'n mode. (cond ((null (setq ll (cdr ll))) (err 'no_match)) ((and (setq x (member x (car ll))) (null (atom (setq x (cdr x))))) (go lp)) ) (go lp1) ))) ;--- edit4f1 --called by edit4f to implement finding a pattern in an ; expression ; s-expression to find ; a-expressio to search ; lvl-the maximum level to search to ; (def edit4f1 (lambda (s a lvl) (prog nil ; check level (cond ((null (greaterp lvl 0)) (return nil))) lp (cond ((atom a) (return nil)) ; ground clause ((and (edit4e s (car a)) (or (null n) (equal 0 (setq n (sub1 n)))) ; what if n is not ) ; a number (return (tconc a ff))) ((and s (equal s (cdr a)) ; should this be edit4e (or (null n) (equal 0 (setq n (sub1 n)))) ) (return (tconc a ff))) ((and n (edit4f1 s (car a) (sub1 lvl)) (equal 0 n)) (return (tconc (car a) ff))) ; this is why we get duplicate ) ; entries in the edit chain. ; we should save the original ; expression. (setq a (cdr a)) (go lp) ))) ;--- tconc -- used only in edit4f1 ; used to maintain a list head for efficent concatenation ; of list. ; x-new element for the list ; p-list head ; (def tconc (lambda (x p) (cond ((null (car p)) ; car p is the list we are maintaining (rplacd p (car (rplaca p (list x))))) ; cdr p points to the ; last element. (t (rplacd p (cdr (rplacd (cdr p) (list x))))) ))) ;---editnth -- implemnts the "nth" command ; x-the ce ; n-the argument to "nth" ; editnth is also used by other commands which take nummeric ; arguments(i.e. bo bi lo ...). if editnth is expanded to take ; non-numberic arguments the so can these commands. ; (def editnth (lambda (x n) ; check to see that n > 0 (cond ((null (setq n (cond ((greaterp n 0) (nthcdr (sub1 n) x)) )) ) (err nil)) (t n) ))) ;---bpnt --used by the command to prints a section of the curr exp to a ; given level. ; x-the command (def bpnt (lambda (x) (prog (y n) (cond ((equal 0 (car x)) (setq y (car l))) (t (setq y (car (editnth (car l) (car x)))))) (cond ((null (cdr x)) (setq n 3)) ((null (numberp (cadr x))) (go b1)) ((lessp (cadr x) 0) (setq n (plus (cadr x) 2))) (t (setq n (cadr x)))) (return (bpnt0 y 1 n)) b1 (err nil) ))) ;---bpnt0 --used by bpnt to implement the print to a level command ; (def bpnt0 (lambda (l n d) (prog (oldl) ; presever the old $$$printlevel for restoration later (setq oldl (printlevel (difference d n))) (cond ((atom (errset (eprint l) t)) (terpri) (terpri))) (printlevel oldl) (return nil) ))) ; ; this group of functions implements the parentheses moving commands. ; in each "x" is the ce and "n" & "m" are the argumments to the ; command ; (define ( (ro (lambda (n x) (prog (a) (setq a (editnth x n)) (cond ((or (null a) (atom (car a))) (err nil))) (rplacd (last (car a)) (cdr a)) (rplacd a nil) ))) (ri (lambda (m n x) (prog (a b) (setq a (editnth x m)) (setq b (editnth (car a) n)) (cond ((or (null a) (null b)) (err nil))) (rplacd a (nconc (cdr b) (cdr a))) (rplacd b nil) ))) (li (lambda (n x) (prog (a) (setq a (editnth x n)) (cond ((null a) (err nil))) (rplaca a (cons (car a) (cdr a))) (rplacd a nil) ))) (lo (lambda (n x) (prog (a) (setq a (editnth x n)) (cond ((or (null a) (atom (car a))) (err nil))) (rplacd a (cdar a)) (rplaca a (caar a)) ))) (bi (lambda (m n x) (prog (a b) (setq b (cdr (setq a (editnth x n)))) (setq x (editnth x m)) (cond ((and a (null (greaterp (length a) (length x)))) (rplacd a nil) (rplaca x (cons (car x) (cdr x))) (rplacd x b)) (t (err nil)) ) ))) (bo (lambda (n x) (prog nil (setq x (editnth x n)) (cond ((atom (car x)) (err nil))) (rplacd x (nconc (cdar x) (cdr x))) (rplaca x (caar x)) ))) )) ;--- subpair --used for subsituting parameter in edit macros ; x-paramter list ; y-argument list for the macro ; z-macro definition ; fl-flag which tells whether of not to copy z ; (def subpair (lambda (x y z fl) (cond (fl (subpr x y (copy z))) ((subpr x y z))))) ;--- subpr --implements parameter passing for subpair ; (def subpr (lambda (x y z) (prog (c d) (setq c x) (setq d y) loop (cond ((or (null c) (null d)) (return z)) (t (dsubst (car d) (car c) z) (setq c (cdr c)) (setq d (cdr d)) (go loop)) ) ))) (def ldiff (lambda (x y) (prog (a b) (setq a x) (setq b nil) loop (cond ((equal a y) (return (reverse b))) ((null a) (return (err nil))) (t (setq b (cons (car a) b)) (setq a (cdr a)) (go loop)))))) (def editv (lambda editvx (prog nil (set (car editvx) (car (edite (eval (car editvx)) (cdr editvx) nil))) (return (car editvx))))) ;---nthcdr -- this function takes the cdr "n" times. ; (def nthcdr (lambda (n x) (cond ((equal n 0) x) ((lessp n 0) (cons nil x)) (t (nthcdr (sub1 n) (cdr x))) ))) (def attach (lambda (x y) (prog (a) (setq a (cons (car y) (cdr y))) (rplaca y x) (rplacd y a) (return y)))) (def eprint (lambda (x) (print (eprint1 x $$$printlevel)))) ;---edite -- this function is the command loop for the editer. ; x -- the expression to edit ; ops -- a list of commands to execute before asking for more ; l -- a ce chain to use; if none is provided a top level one ; is constructed. ; (def edite (lambda (x ops l) ; these are global variables used extensively in editcom. (prog (c m em edok copied pf pl) ; if no edit chain is supplied the construct one. (cond ((null l) (setq l (list x)))) ; get the global edit macros... (setq em editmacros) ; and the print flag... (setq pf printflag) ; and start with the default print level. (setq pl 3) ; if there are any commands, execute them. (cond (ops (cond ((dtpr (errset (mapc (function (lambda (x) (editcom (setq c x)))) ops) t)) (return (car (last l)))) (t (go b)) ) ) ) (print 'edit) (cond (pf (terpri) (editcom 'p))) (setq pf printflag) ct (setq findflag nil) ; this is the top of the edit read loop. ; if an "ok" command is executed, then edok will be non-nil a (cond (edok (return edok))) (terpri) (patom '#) (drain) ; flush the i/o buffers (cond ((null (setq c (read))) (go ct))) ; if nil reset pf (cond ((null (atom (editcom c))) ; if an atom is returned ; by editcom then an error ; occured (cond (pf (editcom 'p))) (setq pf printflag) (go a))) b (terpri) (print c) (patom '?) (terpri) (go ct) ))) ;-- editdefault --the default edit command is a find. (def editdefault (lambda (x) (editcom (list 'f x t)))) ;--- editcom -- this function interprets all the commands for edite ; c-the command to be executed ; this function returns the edit chain for successful completion ; and nil for an error ; (def editcom (lambda (c) (prog (cc c2 c3 cl) ; i don't know what this is either! a (cond(findflag (setq findflag nil) (editqf c)) ; numeric commands are all preformed by edit1f. ((numberp c) (setq l (edit1f c l))) ; all the atomic commands, except the numerics, are ; preformed in this clause. ((atom c) (cond ((eq c 'ok) (setq ersetflg t) ; edok is check by edite. (setq edok (cons t (car (last l)))) (setq pf nil) ; we don't want to print on ; an ok command (return edok)) ; eval command ((eq c 'e) (setq ersetflg t) (print (eval (read))) (terpri)) ; print command ((eq c 'p) (setq pf nil) (bpnt0 (car l) 1 pl)) ; pretty print command ((eq c 'pp) (setq pf nil) (terpri) (errset ($prpr (car l)) t) (terpri)) ; return to toplevel expression ((eq c '^) (setq l (last l))) ; the user can use the copy command if he ; expects to make a mistake. ((eq c 'copy) (setq copied (copy l))) ; restore whzat was copied. note the only one ; level is allowed ((eq c 'restore) (setq l copied)) ; mark is implemented as a stack of marked ; expressions. ((eq c 'mark) (setq m (cons l m))) ; move back to the last mark ((eq c '<) (cond (m (setq l (car m))) (t (err "no marks")))) ; move back to the last mark & erase the mark. ; note that the user can have as many as he ; wants. ((eq c '<<) (cond (m (setq l (car m)) (setq m (cdr m))) (t (err "no marks")))) ; turn off the print flag. ((eq c 'poff) (setq pf nil) (setq printflag nil)) ; turn on the print flag. ((eq c 'pon) (setq pf t) (setq printflag t)) ; if all else fails search the macros table for ; a macro with this name (t (cond ((and (setq cc (cond ((null (setq cc (assoc c em))) nil) (t(cdr cc)) )) (null (car cc))) ; an atomic macros simply specifiy ; a list of commands (editcoms (copy (cdr cc)))) ; if there are no macros, then use the ; defaul edit command which is to find the ; atom on the toplevel (t (return (editdefault c))) )) ) ) ; commands that sart with a number use edit2f ((numberp (setq cc (car c))) (edit2f c)) ; ; here is where we handle the remainder of the commands ; (t(setq c2 (cadr c)) ; c2 & c3 are the first and (setq c3 ; second paramters of the command. (cond ((null (cddr c)) nil) (t(car (cddr c))))) (setq cl (car l)) ; cl gets the ce which the reader ; will note is the car of the ; edit chain. ; the set command (cond ((eq cc 's) (set c2 (car (cond ((null (setq c c3)) l) ((equal c 0) l) (t (editnth cl c)))) )) ; the replace command ((eq cc 'r) (dsubst c3 c2 cl)) ; another eval command ((eq cc 'e) (setq cc (eval c2)) (cond ((null (cddr c)) (print cc) (terpri))) (return cc)) ; the evaluate insert/replace command ((eq cc 'i) (setq c (cons (cond ((atom c2) c2) (t (eval c2))) (mapcar (function eval) (cddr c)) )) (go a)) ; the nconc command ((eq cc 'n) (nconc cl (cdr c))) ; the print element to level command ((eq cc 'p) (bpnt (cdr c)) (setq pf nil)) ; find element at top level ((eq cc 'f) (edit4f c2 c3)) ; caution*** this command is not debugged yet. ; nth command ((eq cc 'nth) (setq l (cons (editnth cl c2) l))) ; the parentheses moving commands ((member cc '(ri ro li lo bi bo)) (apply1 cc (append (cdr c) (list cl)))) ; ; these two commands set edit macros. ; "m" sets global marcros ; "d" sets macros local to this edit session ; ((member cc '(m d)) (setq cc (cond ((atom (setq cc c2)) (cons cc (cons nil (cddr c))) ) (t (cons (car cc) (cddr c))) )) (setq em (cons cc em)) (cond ((eq (car c) 'm) (setq editmacros (cons cc editmacros))) ) ) ; set the print level ((eq cc 'pl) (cond ((lessp c2 1) (err nil)) (t (setq pl (add1 c2))))) ; if we don't recognize the command, then we ; search the macro table (t (cond ((or (null (setq cc ; cc is nil or the ; macro (cond ((null (setq cc (assoc cc em))) nil) (t (cdr cc))))) (null (cond ((null cc) nil) (t (car cc)))) ) ; if we can't find the macros the try ; the default, which is to find the ; command in the top level. (return (editdefault c)) ) ; if we find the macro then ; execute it. ((atom (car cc)) (editcoms (subst (cond ((null c) nil) (t (cdr c))) (car cc) (cadr cc))) ) (t (editcoms (subpair (car cc) (cdr c) (cdr cc) t)) ) ) ) ) ) ) (return (car l)) ; return the ce ))) (def eprint1 (lambda (x lev) (cond ((atom x) x) ((equal 0 lev) '&) ((and (atom (cdr x)) (cdr x)) x) (t (mapcar (function (lambda (y) (eprint1 y (sub1 lev)))) x))))) (def assoc (lambda (e l) (cond ((null l) nil) ((equal e (caar l)) (car l)) (t (assoc e (cdr l)))))) ;---apply1 -- this function applies "f" to the argument list "l" with ; the elements of l quoted. ; (def apply1 (lambda (f l) (eval (cons f (mapcar (function (lambda (z) (list 'quote z))) l) )) )) (def editp (lambda x (prog (a b) (setq a (car x)) (edite (caar x)) (return a)))) (def makefile (lambda x (prog (poport n f ff l df) (setq l (cons nil (cadr x))) (setq ff (eval (car x))) (setq poport (outfile (setq n (concatp 'mkfl)))) l1 (cond ((null (setq l (cdr l))) (go e1))) (setq f (car l)) (cond ((null f) (go l1)) ((null (setq df (getd f))) (go l1)) (t (setq df (list 'def f df)) ($prpr df) (terpri) (go l1))) e1 (close poport) (null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil))))))))) (def appfile (lambda x (prog (i poport n f ff l df) (setq l (cons nil (cadr x))) (setq ff (eval (car x))) (setq i (infile ff)) (setq poport (outfile (setq n (concatp 'apfl)))) l1 (cond ((eq (setq f (read i poport)) 'eof) (go l2)) (t ($prpr f) (terpri))) (go l1) l2 (cond ((null (setq l (cdr l))) (go e1))) (setq f (car l)) (cond ((null f) (go l2)) ((null (setq df (getd f))) (go l2)) (t (setq df (list 'def f df)) ($prpr df) (terpri) (go l2))) e1 (close poport) (null (eval (cons 'exec (cons '/bin/mv (cons n (cons ff nil))))))))) (def exec (lambda $list (prog ($handy) (setq $handy "") loop (cond ((null $list) (return (eval (list 'process $handy)))) (t (setq $handy (concat (concat $handy (car $list)) " ")) (setq $list (cdr $list)) (go loop)))))) (setq editmacros nil) nil #-t- edit.lsp 35591 ascii 15-Jan-84 14:18:02 #-h- fact.lsp 87 ascii 15-Jan-84 14:18:06 (defun fact (n) (cond ((zerop n) 1) (t (times n (fact (difference n 1)))) ) ) nil #-t- fact.lsp 87 ascii 15-Jan-84 14:18:06 #-h- fib.lsp 154 ascii 15-Jan-84 14:18:06 (defun fib (x) (cond ((zerop x) 1) ; if 0, result is 1. ((onep x) 1) ; if 1, result is 1. (t (plus (fib (sub1 x)) (fib (difference x 2)))))) nil #-t- fib.lsp 154 ascii 15-Jan-84 14:18:06 #-h- fib1.lsp 293 ascii 15-Jan-84 14:18:06 (defun fib1 (n) (fib1_aux 1 1 1 n)) (defun fib1_aux (fo fn i n) (cond ((equal i n) fn) ; Terminating condition (t (fib1_aux fn ; f(n-1) (plus fo fn) ; f(n) + f(n-1) (add1 i) ; Count up. n)))) ; until i == n. nil #-t- fib1.lsp 293 ascii 15-Jan-84 14:18:06 #-h- roots.lsp 6751 ascii 15-Jan-84 14:18:07 ; see p.167 of Winston... (defun linear (a b) (cond ((zerop a) (cond ((zerop b) (print 'Homogeneous) (terpri) nil) ; a == 0 & b == 0 (t (print 'Inconsistent) (terpri) nil))) ; a == 0 & b != 0 ((zerop b) '((0.0 0.0))) ; a != 0 & b == 0 (t (list (list (minus (quotient b a)) 0.0))))) ; a != 0 & b != 0 (defun quadratic_conjugate (real imaginary) (list (list real imaginary) (list real (minus imaginary)))) (defun quadratic_real (a term c) (list (list (quotient term (times 2.0 a)) 0.0) (list (quotient (times 2.0 c) term) 0.0))) (defun quadratic_aux (a b c discriminant) (cond ((minusp discriminant) ; Conjugate pair (quadratic_conjugate (minus (quotient b (times 2.0 a))) (quotient (sqrt (minus discriminant)) (times 2.0 a)))) ((zerop discriminant) ; Double root (list (list (minus (quotient b (times 2.0 a))) 0.0) (list (minus (quotient b (times 2.0 a))) 0.0))) ((minusp b) ; Real roots b < 0 (quadratic_real a (difference (sqrt discriminant) b) c)) (t (quadratic_real a ; Real roots b >= 0 (minus (plus (sqrt discriminant) b)) c)))) (defun quadratic (a b c) (cond ((zerop a) (linear b c)) ; a == 0 ((zerop c) (cons '(0.0 0.0) (linear a b))) ; c == 0 (t (quadratic_aux a b c (difference (times b b) ; Discriminant (times 4.0 a c)))))) (defun cubic_conjugate_aux (real_root real imaginary) (list (list real_root 0.0) ; Real root first. (list real imaginary) (list real (minus imaginary)))) (defun cubic_conjugate (a b r s) ; r & s are cube roots. (cubic_conjugate_aux (quotient (difference (plus r s) b) (times a 3.0)) (quotient (difference (minus (quotient (plus r s) 2.0)) b) (times a 3.0)) (quotient (times (difference r s) (quotient (sqrt 3.0) 2.0)) (times a 3.0)))) (defun cubic_real_aux (a b rd cd sd) ; if a>0, most positive first. (list (list (quotient (difference (times -2.0 rd cd) b) (times 3.0 a)) 0.0) (list (quotient (difference (times rd (plus cd sd)) b) (times 3.0 a)) 0.0) (list (quotient (difference (times rd (difference cd sd)) b) (times 3.0 a)) 0.0))) (defun cubic_real (a b rho theta) ; Rho & theta of complex root. (cubic_real_aux a b (times 2.0 (curt rho)) (times (cos (quotient theta 3.0)) -0.5) (times (sin (quotient theta 3.0)) -0.5 (sqrt 3.0)))) (defun cubic_aux (a b roots) (cond ((zerop (cadar roots)) (cubic_conjugate a ; Resolvent roots real. b (curt (caar roots)) ; Pick out real parts. (curt (caadr roots)))) (t (cubic_real a ; Roots complex. b (sqrt (plus (times (caar roots) (caar roots)) ; Modulus (times (cadar roots) (cadar roots)))) (atan (cadar roots) ; Argument (caar roots)))))) (defun cubic (a b c d) (cond ((zerop a) (quadratic b c d)) ; a == 0 (t (cubic_aux a b (quadratic 1.0 ; Resolvent (plus (times 2.0 b b b) (times 9.0 a (difference (times 3.0 a d) (times b c)))) (expt (difference (times b b) (times 3.0 a c)) 3)))))) ; Return the CUBE ROOT of x. (defun curt (x) (cond ((zerop x) 0.0) (curt_iter (cond ((minusp x) (minus (exp (quotient (log (minus x)) 3.0)))) ((zerop x) 0.0) (t (exp (quotient (log x) 3.0))))) x)) (defun curt_iter (x y) (quotient (plus x x (quotient y (times x x))) 3.0)) (defun quartic_split (a b r1 s r2 bs_2ad) (cond ((minusp (times r1 r2 bs_2ad)) ; r1 r2 same as bs_2ad? (append (quadratic (times 2.0 a) ; No. (difference b r1) (plus s r2)) (quadratic (times 2.0 a) (plus b r1) (difference s r2)))) (t (append (quadratic (times 2.0 a) ; Yes. (difference b r1) (difference s r2)) (quadratic (times 2.0 a) (plus b r1) (plus s r2)))))) (defun quartic_aux (a b c d e s) ; s is root of resolvent. (quartic_split a b (sqrt (difference (times b b) (times 4.0 a (difference c s)))) s (sqrt (difference (times s s) (times 4.0 a e))) (difference (times b s) (times 2.0 a d)))) (defun quartic (a b c d e) (cond ((zerop a) (cubic b c d e)) ; a == 0 ((zerop e) (cons '(0.0 0.0) (cubic a b c d))) ; e == 0 (t (quartic_aux a b c d e (caar (cubic 1.0 ; Resolvent cubic. (minus c) (difference (times b d) (times 4.0 a e)) (difference (times 4.0 a c e) (plus (times a d d) (times b b e))))))))) #-t- roots.lsp 6751 ascii 15-Jan-84 14:18:07 #-h- ucimac.lsp 4080 ascii 15-Jan-84 14:18:08 (define ( (loop (macro l (prog (val) (setq val (loop1 (cdr l) (get-keyword 'initial l) (get-keyword 'result l))) (rplaca l (car val)) (rplacd l (cdr val)) (return val)))) )) (defun loop1 (clauses i-body r-body) (prog (form) (setq form (list 'prog (var-list i-body))) (setq form (append form (setq-steps i-body) '(loop))) (while clauses (setq form (append form (do-clause (car clauses)))) (setq clauses (cdr clauses)) ) (setq form (append form (list '(go loop) 'exit (cons 'return r-body)))) (return form) )) (defun get-keyword (key l) ((lambda (x) (cond (x (cdr x)))) (assoc key (cdr l))) ) (defun do-clause (clause) (selectq (car clause) ((initial result) nil) (while (list (list 'or (cadr clause) '(go exit)))) (do (cdr clause)) (until (list (list 'and (cadr clause) '(go exit)))) (prog () (princ "UNKNOWN KEY WORD") (terpri) (break)) )) (defun var-list (l) (cond ((null l) nil) (t (cons (car l) (var-list (cddr l)))) )) (defun setq-steps (l) (cond ((null l) nil) (t (cons (list 'setq (car l) (cadr l)) (setq-steps (cddr l))) ))) (define ( (selectq (macro selectq-$$$x (prog (form test clauses) (setq form (list 'prog '(selectq-$$$x) (list 'setq 'selectq-$$$x (cadr selectq-$$$x)))) (setq test '(cond)) (setq clauses (cddr selectq-$$$x)) (while (cdr clauses) (setq test (append test (list (cons (list 'or (list 'equal 'selectq-$$$x (list 'quote (caar clauses))) (list 'membq 'selectq-$$$x (list 'quote (caar clauses)))) (cdar clauses))) )) (setq clauses (cdr clauses)) ) (cond (clauses (setq test (append test (list (list t (car clauses))))))) (setq form (append form (list (list 'return test)))) (rplaca selectq-$$$x (car form)) (rplacd selectq-$$$x (cdr form)) (return form) ))) (push (macro x (prog (val) (setq val (list 'setq (caddr x) (list 'cons (cadr x) (caddr x))) ) (rplaca x (car val)) (rplacd x (cdr val)) (return val)))) (pop (macro x (prog (val) (setq val (list 'prog '(pop-$$$x) (list 'cond (list (list 'null (cadr x)) (list 'return nil))) (list 'setq 'pop-$$$x (list 'car (cadr x))) (list 'setq (cadr x) (list 'cdr (cadr x))) (list 'return 'pop-$$$x)) ) (rplaca x (car val)) (rplacd x (cdr val)) (return val)))) )) (defun cons-end (l x) (append l (list x))) (setq not null) (define ( (for (macro l (prog (val) (setq val (for1 (cadr l) (get-keyword 'when l) (get-keyword 'do l) (get-keyword 'save l) (get-keyword 'exists l) )) (rplaca l (car val)) (rplacd l (cdr val)) (return val)))) )) (defun for1 (in when do save exists) (cons (for-mapfn when do save exists) (cons (for-lambda (car in) when do save exists) (cddr in)))) (defun for-mapfn (when do save exists) (cond (do 'mapc) (exists 'some) (when 'mapcan) (t 'mapcar))) (defun for-lambda (var when do save exists) (list 'function (cons 'lambda (cons (list var) (cond (when (for-when when do save )) (t (or do save exists))) ))) ) (defun for-when (when do save) (list (list 'cond (append (add-progn when) (or do (list (cons 'list (add-progn save))))))) ) (defun add-progn (l) (cond ((cdr l) (cons 'progn l)) (t l))) (defun some (fn l) (prog (val) (while l (cond ((setq val (apply fn (list (car l)))) (return val))) (setq l (cdr l)) ))) (define ( (let (macro l (prog (val) (setq val (let1 (reverse (cadr l)) nil nil (cddr l))) (rplaca l (car val)) (rplacd l (cdr val)) (return val)) )) )) (defun let1 (l vars vals body) (cond ((null l) (cons (cons 'lambda (cons vars body)) vals)) (t (let1 (cddr l) (cons (cadr l) vars) (cons (car l) vals) body)) )) (defun consp (x) (null (atom x))) (defun msg msg-$$$x (for (msg-$$$y in msg-$$$x) (do (cond ((eq msg-$$$y t) (terpri)) ((stringp msg-$$$y) (princ msg-$$$y)) (t (print (eval msg-$$$y))) )))) #-t- ucimac.lsp 4080 ascii 15-Jan-84 14:18:08 #-t- lisps.ar 51839 ascii 15-Jan-84 14:28:13 #-h- make.sh 290 ascii 15-Jan-84 14:28:18 date echo There will be 2 compilation errors reported by this procedure: echo [1] No path to statement in module PROG echo [2] No path to statement in module RATOM echo It takes about 20 minutes to rebuild LISP on an unloaded 780. rm -f rcrsv.obj macr rcrsv /nolist rc -d lisp.r rcrsv date #-t- make.sh 290 ascii 15-Jan-84 14:28:18 #-h- makeman.sh 268 ascii 15-Jan-84 14:28:19 ar x refman.ar format conten.fmt intro.fmt @ chap01.fmt chap02.fmt chap03.fmt chap04.fmt chap05.fmt @ chap06.fmt chap07.fmt chap08.fmt chap09.fmt chap10.fmt @ chap11.fmt chap12.fmt chap13.fmt chap14.fmt @ apndxa.fmt apndxb.fmt apndxc.fmt >lisp.man ar t refman.ar | rm #-t- makeman.sh 268 ascii 15-Jan-84 14:28:19 #-h- rcrsv.mar 921 ascii 15-Jan-84 14:28:19 .title RCRSV .ident /Recursion Primitives/ ; The function "jcall" performs an indirect subroutine jump to a ; function with no parameters. jcall:: .word ^m movl @4(ap), sub calls #0, @sub ret ; The function "jmp" performs a jump into another routine. ; The paramters for "jmp" are: ; (1) the procedure name (declared as external) ; (2) the offset in the procedure (as produced by a FORTRAN ASSIGN) ; (3) the stack pointer (SP) to be replaced for the procedure. jmp:: .word ^m movl 4(ap), r0 addl2 @8(ap), r0 movl @12(ap), savedsp While: cmpl 12(fp), savedsp beql EndWhile movl 12(fp), fp brb While EndWhile: movl fp, sp movl r0, 16(fp) ret ; "rtrvsp" is used to find the current value of the stack pointer (SP). ; It is usually used with "jmp". "rtrvsp" takes its own calling ; into account. rtrvsp:: .word ^m movl sp, r0 addl2 #20, r0 ret sub: .blka 1 savedsp: .blka 1 .end #-t- rcrsv.mar 921 ascii 15-Jan-84 14:28:19 #-h- refman.ar 68440 ascii 15-Jan-84 14:28:21 #-h- lisp.hdr 433 ascii 15-Jan-84 13:51:12 .in 5 .rm 72 .pl 64 .de PG .sp .fi .ju .ti +5 .en .de BF .ne 11 .nf .sp .in +5 .ti -5 .en .de EF .in -10 .en .de RE .nf RETURNS .in +5 .fi .en .de SE .in -5 .nf SIDE EFFECTS .in +5 .fi .en .de EC .in -5 .nf ERROR CONDITIONS .in +5 .fi .en .de OE .in -5 .nf ON_ERROR .in +5 .fi .en .de FS .in -5 .nf FSUBR .in +5 .fi .en .de SU .in -5 .nf SUBR .in +5 .fi .en .de LS .in -5 .nf LSUBR .in +5 .fi .en .de LA .nf .in -5 LAMBDA .in +5 .en #-t- lisp.hdr 433 ascii 15-Jan-84 13:51:12 #-h- conten.fmt 1873 ascii 15-Jan-84 13:51:12 .so lisp.hdr .he ''Software Tools LISP Reference Manual'' .sp .ce TABLE OF CONTENTS .sp .nf .nj .in +1 0.0 Introduction 1.0 Documentation Conventions 2.0 Atomic Data Types .in +5 2.1 Symbols ............................................. 2-1 2.2 Characters .......................................... 2-2 2.3 Strings ............................................. 2-2 2.4 Numbers ............................................. 2-4 .in -5 3.0 Functional Bindings 4.0 Compiled Functions .in +5 4.1 SUBRs ............................................... 4-1 4.2 FSUBRs .............................................. 4-1 4.3 LSUBRs .............................................. 4-1 4.4 ARRAYs .............................................. 4-1 4.5 ICHANNELs and OCHANNELs ............................. 4-3 .in -5 5.0 Interpreted Functions 6.0 Functions on Lists 7.0 Predicates 8.0 Executional Forms 9.0 Input/Output .in +5 9.1 Channel Manipulation ................................ 9-2 9.2 READing ............................................. 9-3 9.3 PRINTing ............................................ 9-6 9.4 LOADing Files ....................................... 9-7 .in -5 .in -1 10.0 Error Processing and Debugging 11.0 Miscellaneous Functions 12.0 LISP Objects in Memory .in +6 12.1 Atomic Nodes ....................................... 12-1 .in +5 12.1.1 Symbols ..................................... 12-1 12.1.2 Strings ..................................... 12-2 12.1.3 Numbers ..................................... 12-2 12.1.4 SUBRs ....................................... 12-3 .in -5 12.2 List Nodes ......................................... 12-3 .in +5 12.2.1 Array Blocks ................................ 12-5 .in -5 .in -6 .sp 2 .ce APPENDICES .sp A An Example Session B The LISP Editor C Functions for Accessing Atomic Nodes from RatFor #-t- conten.fmt 1873 ascii 15-Jan-84 13:51:12 #-h- intro.fmt 1235 ascii 15-Jan-84 13:51:12 .so lisp.hdr .bp .ce .fo ''-i-'' INTRODUCTION .sp 2 .PG This LISP interpreter was originally written as an honors project for the UCLA Mathematics Department by Charlie Dolan, under the advisorship of Professor David F. Martin of the UCLA Computer Science Department. The interpreter was developed on an HP 1000 computer running RTE-IVB and was then ported to VAX/VMS by Charlie Dolan and Dave Martin (no relation to David F. Martin) of Hughes Aircraft. .PG The interpreter is written in RATFOR, a FORTRAN preprocessor. RATFOR is part of the SOFTWARE TOOLS concept developed by Kernighan and Plaugher. Many of the other concepts from SOFTWARE TOOLS have also been used. This makes the system easier to bring up at installations where SOFTWARE TOOLS have been implemented. .PG Bringing up the system requires writing six recursion primitives in machine language and three primitives for manipulating Hollerith constants. If the host machine has a stack then only four of the recursive primitives need to be implemented. .PG The interpreter has also been written to make memory overlays possible. This can be much more machine dependent than any of the above mentioned primitives and can make bringing up the system much more difficult. #-t- intro.fmt 1235 ascii 15-Jan-84 13:51:12 #-h- chap01.fmt 1370 ascii 15-Jan-84 13:51:13 .so lisp.hdr .bp 1 .he ''DOCUMENTATION CONVENTIONS'' .fo ''1-#'' 1.0 DOCUMENTATION CONVENTIONS .PG For brevity and quick reference each function's specifications will be given as it is invoked from the interpreter. The allowable types for function arguments will be denoted by the first character of the name according to this table: .sp .in +5 .nf e -- any S-expression a -- any atomic data type v -- any symbolic name n -- any number l -- a list s -- a string f -- a function .in -5 .fi .PG Also given with each function will be the value it returns, its side effects (if any), its discipline (SUBR, FSUBR, LSUBR or LAMBDA), what conditions cause errors, and an 'ON_ERROR value'. The 'ON_ERROR value' is what the user should return, via the BREAK package, if an error occurs. Error returns are covered more fully under DEBUGGING. If a function has no ERROR CONDITIONS listed, then it is defined for all arguments, but an error could still occur in EVALuating the arguments. For example: .BF (car e-arg) .RE the car of the expression .SU .EC e-arg is atomic. .OE provide any S-expression appropriate to the calling context. .EF .PG Arguments which are not EVALuated by the function are preceded by a "'". For example: .sp .in +5 .nf (setq 'v-arg e-arg) .in -5 .fi .PG Optional parameters are enclosed in braces { }, and unless otherwise specified are defaulted to nil. #-t- chap01.fmt 1370 ascii 15-Jan-84 13:51:13 #-h- chap02.fmt 8070 ascii 15-Jan-84 13:51:13 .so lisp.hdr .bp 1 .he ''ATOMIC DATA TYPES'' .fo ''2-#'' 2.0 ATOMIC DATA TYPES .sp 2.1 SYMBOLS .PG Symbols correspond to variable names in most other programming languages. In the interpreter each name is INTERNed on the OBLIST so that every time it is encountered by READ, it will be returned as the same unique address. .PG Symbolic names may be any string which does not begin with one of {+,-,',0-9} and does not contain any of {+,-,'}. Although in principle there is no limit to the length of a name, names longer then 80 characters may cause errors. .PG Each symbolic name has associated with it a property list. This list contains all the pertinent information about the symbol: its value, its print name (PNAME), and anything else the user wants to put there. .nf .BF (defprop 'v-arg1 'e-arg 'v-arg2) .RE v-arg1. .SE Places e-arg on the property list of v-arg1 under the property v-arg2. .FS .EC v-arg1 or v-arg2 is not a symbol. .OE provide any atomic value. .EF .BF (get v-arg1 v-arg2 {e-arg}) .RE the value under the property v-arg2 on the property list of v-arg1. If the property is not there then e-arg is returned .SU .EC v-arg1 or v-arg2 is not a symbol. .OE provide any appropriate S-expression. .EF .BF (putprop v-arg1 e-arg v-arg2) .RE e-arg .SE Places e-arg on the property list of v-arg1 under the property v-arg2. .SU .EC v-arg1 or v-arg2 is not a symbol. .OE provide any S-expression appropriate to the calling context. .EF .BF (remprop v-arg1 v-arg2 {e-arg}) .RE The value under the tag v-arg2 on the property list of v-arg1. If the property is not there then e-arg is returned. .nf .SE Removes the property v-arg2 from the property list of v-arg1. .nf .SU .EC v-arg1 or v-arg2 is not a symbol. .OE provide any S-expression appropriate to the calling context. .EF .BF (set v-arg e-arg) Equivalent to, (putprop v-arg e-arg 'value) .in +5 .EC v-arg is not a symbol. .EF .BF (setq 'v-arg e-arg) Equivalent to, (putprop 'v-arg e-arg 'value) .in +5 .EC v-arg is not a symbol. .EF .sp 2 .fi 2.2 CHARACTERS .PG Character literals are distinguished from 1-character atoms by a preceding BACKSLASH ('\') since the single-quote is conventionally used to quote atoms. When the reader "ratom" encounters a BACKSLASH, it returns the symbol which has the next character in the input stream as its PNAME. Thus "\*" returns the atom for '*' not the character string "*". .sp 2 .fi 2.3 STRINGS .PG Strings are any sequence of characters surrounded by double quotes. For example: .sp .in +5 .nf "This is a string" "Strings can have any characters ''+-" "A double quote "" can be included in the usual way" .in -5 .fi .PG Strings are allocated in a heap fashion and are not recoverable. Most of the string routines will not work on strings longer than 256 characters. .sp .in +5 .nf .BF (concat s-arg ...) .RE the result of concatenating the s-args. .LS .EC a non-string argument was supplied. .OE provide a string. .EF .BF (eq s-arg1 s-arg2) .RE t if the strings are exactly the same , nil otherwise. .SU .EC none .EF .BF (explode s-arg) .RE a list of one-character atoms whose PNAMES are the characters of s-arg. For example: .nf (explode "charlie") returns (c h a r l i e) .SU .EC s-arg is not a string. .OE provide a list. .EF .BF (greaterp s-arg1 s-arg2) .RE t if s-arg1 is lexically greater then s-arg2, othwise nil. .SU .EC none .EF .BF (index s-arg1 s-arg2) .RE if s-arg1 is a substring of s-arg2 the starting postion of the substring s-arg2 (1 origin), otherwise nil. .nf .SU .EC s-arg1 or s-arg2 is not a string. .OE provide a number or nil. .EF .BF (lessp s-arg1 s-arg2) .RE t is s-arg1 is lexically less than s-arg2, otherwise nil. .SU .EC none .EF .BF (substr s-arg n-arg1 n-arg2) .RE the substring of s-arg strating at n-arg1 and n-arg2 characters in length. .nf .SU .EC s-arg1 is not a string. n-arg1 or n-arg2 is not a number. .OE provide a string. .EF .sp 2 .in -5 .fi 2.4 NUMBERS .PG This LISP provides only floating point numbers. Their range is dictated by the host machine. The syntax of numbers in this LISP is the same as for ANSI standard FORTRAN. .PG For small integers this LISP uses INUMs. The addresses 0 to 511 are reserved for the integers -256 to 255. This allows these numbers to be used in loops and as array indexes without having to create new nodes. .sp .in +5 .nf .BF (absval n-arg) .RE the absolute value of n-arg .SU .EC n-arg is not a number. .br n-arg < 0. .OE provide a positive number. .EF .BF (acos n-arg) .RE the arc cosine of n-arg .SU .EC n-arg is not a number. .br n-arg > 1 or n-arg < -1. .OE provide a suitable number. .EF .BF (add1 n-arg) .RE the result of adding one to n-arg. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (asin n-arg) .RE the arc sine of n-arg. .SU .EC n-arg is not a number. .br n-arg > 1 or n-arg < -1. .OE provide a suitable number. .EF .BF (atan n-arg1 n-arg2) .RE the arc tangent of n-arg1/n-arg2. .br If n-arg2 == 0, returns pi/2 with the sign of n-arg1. .SU .EC n-arg1 or n-arg2 is not a number. .br n-arg1 == n-arg2 == 0. .OE provide a suitable number. .EF .BF (cos n-arg) .RE the cosine of n-arg. .br n-arg is assumed to be in radians. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (difference n-arg1 n-arg2) .RE n-arg1 - n-arg2 .SU .EC n-arg1 or n-arg2 is not a number. .OE provide a number. .EF .BF (entier n-arg) .RE the entier of n-arg. .br Entier is the greatest integer <= n-arg. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (eq n-arg1 n-arg2) .RE t if n-arg1 - n-arg2 == 0, otherwise nil. .SU .EC none .EF .BF (evenp n-arg) .RE t if n-arg is an even integer, otherwise nil. .SU .EC n-arg is not a number. .OE provide t or nil. .EF .BF (exp n-arg) .RE e raised to the n-arg power. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (expt n-arg1 n-arg2) .RE n-arg1 ** n-arg2. .SU .EC n-arg1 or n-arg2 is not a number. .OE provide a number. .EF .BF (fix n-arg) .RE n-arg truncated to its integer part. .SU .EC n-arg is a number. .OE provide an integer number. .EF .BF (fixp n-arg) .RE t if n-arg - (fix n-arg) == 0, otherwise nil. .SU .EC n-arg is not a number. .OE provide t or nil. .EF .BF (greaterp n-arg1 n-arg2) .RE t if n-arg1 > n-arg2, otherwise nil. .SU .EC none .EF .BF (lessp n-arg1 n-arg2) .RE t if n-arg1 < n-arg2 , otherwise nil. .SU .EC none .EF .BF (log n-arg) .RE the natural log of n-arg. .SU .EC n-arg is not a number. .br n-arg is <= 0. .OE provide a number. .EF .BF (log10 n-arg) .RE the common log of n-arg. .SU .EC n-arg is not a number. .br n-arg is <= 0. .OE provide a number. .EF .BF (max n-arg1 n-arg2 ...) .RE the maximum of the n-args. .LS .EC Any of the n-argi are not numbers. .OE provide a number. .EF .BF (min n-arg1 n-arg2 ...) .RE the minimum of the n-args. .LS .EC Any of the n-argi are not numbers .OE provide a number. .EF .BF (minus n-arg) .RE -(n-arg). .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (oddp n-arg) .RE t if n-arg is an odd integer, otherwise nil. .SU .EC n-arg is not a number. .OE provide t or nil. .EF .BF (plus n-arg1 n-arg2 ...) .RE the sum of the n-args. .LS .EC Any of the n-argi are not numbers. .OE provide a number. .EF .BF (quotient n-arg1 n-arg2) .RE n-arg1 / n-arg2 .SU .EC n-arg1 or n-arg2 is not a number. .br n-arg2 == 0. .OE provide a suitable number. .EF .BF (random e-arg) .RE a random number in the range 0 <= n < 1. .SE if e-arg is a number, the random number generator is re-seeded with e-arg. if e-arg is not a number, but is non-nil, the generator is re-seeded with the time of day. .SU .EC none .EF .BF (sin n-arg) .RE the sine of n-arg. .br n-arg is assumed to be in radians. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (sqrt n-arg) .RE the square root of n-arg .SU .EC n-arg is not a number .br n-arg is negative .OE provide a number .EF .BF (tan n-arg) .RE the tangent of n-arg. .br n-arg is assumed to be in radians. .SU .EC n-arg is not a number. .OE provide a number. .EF .BF (times n-arg1 n-arg2 ...) .RE the product of the n-args. .LS .EC Any of the n-argi are not numbers. .OE provide a number. .EF .in -5 #-t- chap02.fmt 8070 ascii 15-Jan-84 13:51:13 #-h- chap03.fmt 1314 ascii 15-Jan-84 13:51:15 .so lisp.hdr .bp 1 .he ''FUNCTIONAL BINDINGS'' .fo ''3-#'' 3.0 FUNCTIONAL BINDINGS .PG When EVAL operates on a non-atomic structure, it tries to interpret it as function call. EVAL takes the CAR of the list to be the function definition. For example the following are valid function calls: .sp .in +5 .nf ((lambda (x) (plus x 2)) 3) -> 5 .sp ((label f .in +2 (lambda (i) .in +2 (cond .in +2 ((eq i 0) 1) (t (times i (f (sub1 i)))) .in -2 ) .in -2 ) .in -2 ) 3 ) -> 6 .sp ((subr . #150632) 2 3) -> 5 {if 150632 is the entry point of plus} .sp .in -5 .fi .ce FIG 3-1 Function applications .PG If the CAR of the form is not a function definition then it is EVALuated to yield a function definition. From this we see that if we wish to refer to a function by name then the definition must be on the property list under the property VALUE. This means that a name cannot have both a function binding and another value. .PG If we wanted a factorial function FACT then we could use .ne 10 .sp .in +5 .nf (setq fact .in +2 (quote .in +2 (lambda (i) .in +2 (cond .in +2 ((eq i 0) 1) (t (times i (fact (sub1 i)))) .in -2 ) .in -2 ) .in -2 ) .in -2 ) .sp .in -5 .fi .ce FIG 3-2 Setting a symbol to a function definition .sp but there are more esthetically pleasing forms, which will be presented under INTERPRETED FUNCTIONS. #-t- chap03.fmt 1314 ascii 15-Jan-84 13:51:15 #-h- chap04.fmt 3458 ascii 15-Jan-84 13:51:15 .so lisp.hdr .bp 1 .he ''COMPILED FUNCTIONS'' .fo ''4-#'' 4.0 COMPILED FUNCTIONS .PG There are three calling disciplines for compiled functions in this LISP: SUBRs, FSUBRs, and LSUBRs. Also nominally considered compiled function types are ARRAYs, ICHANNELS, and OCHANNELS. The definitions for these functions look like .sp .ti +5 (type . #nnnnn) .sp where type is SUBR, FSUBR, LSUBR, ARRAY, ICHANNEL, or OCHANNEL and "nnnnn" is the entry point of the function, the offset of the array, or the number of the I/O channel. .sp 2 4.1 SUBRs .PG SUBRs are the most common type of compiled function. SUBRs take a finite number of arguments and have all of them EVALuated. SUBRs may have at most 5 arguments. SUBRs can have optional arguments. Any arguments which are not provided are passed as nil. In fact EVAL assumes all SUBRs have 5 parameters. .sp 2 4.2 FSUBRs .PG FSUBRs receive their arguments unEVALuated in a list. FSUBRs may have indefinitely many arguments. .sp 2 4.3 LSUBRs .PG Like FSUBRs, LSUBRs may have indefinitely many arguments, but they receive them as a list of values already EVALuated. .sp 2 4.4 ARRAYS .PG ARRAYs are created by the user and are manipulated by the functions below: .ne 20 .BF (array dimspec1 dimspec2 ...) .RE a list node of the form (ARRAY . #nnnnn). The array will be dimensioned according to the dimspec's. The dimspec can be in two forms: .sp .nf .in +5 upperbound or (lowerbound . upperbound) .sp .in -5 Lowerbound is defaulted to 0. .SE Allocates space in the ARRAYSPACE for the array and puts in the information on the dimensions. .LS .EC The dimspeci are not numbers or dotted pairs of numbers. .br The lowerbound is larger than the upper bound. .OE provide an array definition (i.e. (ARRAY . #nnnnn)) .EF .BF (store (arraydef n-arg1 n-arg2 ...) e-arg) .RE e-arg. .SE Places e-arg in the cell designated by the n-args. .br Arraydef must be of the form (ARRAY . #nnnnn). .FS .EC Arraydef is not a proper array definition. .br Any of the n-argi are not numbers. .br Any of the n-argi are out of bounds. .OE provide any S-expression .EF .BF (unarray arraydef) .RE t if the deallocation is successful, otherwise nil. Arraydef must be of the form (ARRAY . #nnnnn). .SE Frees the storage occupied by the array. .SU .EC Arraydef is not a proper arrray definition. .OE provide T or nil .EF .sp .in -5 .fi .PG Some examples of using arrays are given below: .ne 35 .sp .in +5 .nf (prog (i a) ; a will be used to reference the array .in +7 (setq a (array (5 . 10))) ; Allocate the array. (setq i 5) .ti -7 label (cond ((eq i 11) (return (unarray a)))) ; Free the array. (store (a i) i) ; Initialize the array. (setq i (add1 i)) (go label) .in -7 ) .sp ; This function returns a triangular array (defun tarray (n) .in +7 (prog (i tarray) .in +7 (setq tarry (array n) (setq i 0) .ti -14 label (cond ((greaterp i n) (return tarry) (store (tarry i) (array i)) (setq i (add1 i)) (go label) .in -7 ) .in -7 ) .sp ; If we create an array with (setq a (tarray 5)) .sp ; We can access it as follows ((a i) j) ; For reading it, or... (store ((a i) j) expr) ; to write to it. .sp .fi .ce FIG 4-1 Using arrays in LISP .sp 2 4.5 ICHANNELs and OCHANNELs .PG In this LISP, I/O is treated just like a function. The two types of compiled functions for I/O are: .sp .ti +5 (ichannel . #nn) and (ochannel . #nn) .sp for input and output respectively. These forms are described more completely under INPUT/OUTPUT. #-t- chap04.fmt 3458 ascii 15-Jan-84 13:51:15 #-h- chap05.fmt 1913 ascii 15-Jan-84 13:51:16 .so lisp.hdr .bp 1 .he ''INTERPRETED FUNCTIONS'' .fo ''5-#'' 5.0 INTERPRETED FUNCTIONS .PG The basic form of interpreted function is the LAMBDA expression. LAMBDA expressions are invoked as follows: .sp .ti +5 ((lambda argspec body) arg1 arg2 ... argm) .PG The body may be any S-expression. It is EVALuated once the binding of the argspec is completed. The argspec has the same form as in VAX/VMS LISP. If argspec is of the form .sp .ti +5 v-arg .sp then the argument list is bound unEVALuated to v-arg. If argspec is of the form .sp .ti +5 (v-arg1 v-arg2 ... v-argn) .sp then the argument list is evaluated and the values are bound to the v-argi. Any parameters for which there are no arguments are bound to nil. The argspec can also be of the form .sp .ti +5 (v-arg1 v-arg2 ... v-argn . lastarg) .sp In this case the first n arguments are EVALuated and bound to the v-argi and the rest of the argument list is bound unEVALuated to lastarg. .PG For functions with temporary names a label form is also provided. LABEL is used for functions which are recursive but for which the user does not want to permanently create a symbol. The LABEL facility is used as follows: .sp .ti +5 ((LABEL v-arg lambda-expression) arg1 arg2 ... argm) .sp The lambda-expression is bound to v-arg and the form .sp .ti +5 (v-arg arg1 arg2 ... argm) .sp is EVALuated. Then v-arg is unbound. .PG The following functions are provided for binding lambda definitions to symbolic names: .BF (define '((v-arg1 lambda-expr1) (v-arg2 lambda-expr2) ...)) .RE a list of the v-argi. .SE It sets the value of each of the v-argi to the corresponding lambda-expr. .FS .EC Any of the v-argi are not symbols. .OE provide any S-expression. .EF .BF (defun 'v-arg arg-spec form) .RE v-arg. .SE Sets the value of v-arg to the lambda expression with argument list "arg-spec" and body "form". .FS .EC v-arg is not a symbol. .OE provide an atomic value. .EF #-t- chap05.fmt 1913 ascii 15-Jan-84 13:51:16 #-h- chap06.fmt 2997 ascii 15-Jan-84 13:51:16 .so lisp.hdr .bp 1 .he ''FUNCTIONS ON LISTS'' .fo ''6-#'' .BF (car e-arg) .RE the car of the e-arg. .SU .EC E-arg is atomic. .OE provide any S-expression appropriate to the calling context. .EF .BF (cdr e-arg) .RE the cdr of the e-arg. .SU .EC E-arg is atomic. .OE provide an appropriate S-expression. .EF .BF (c??r e-arg) .RE just what you would expect depending on ??. .SU .EC e-arg is atomic or the specified sequence of CARs and CDRs cannot be taken. .OE provide any S-expression. .EF .BF (cons e-arg1 e-arg2) .RE the dotted pair with e-arg1 as its CAR and e-arg2 as its CDR. .SU .EC none .EF .BF (list e-arg1 e-arg2 ...) .RE the list with the e-argi as its elements. .SU .EC none .EF .BF (nconc l-arg1 l-arg2) .RE l-arg1. .SE Replaces the cdr of the last node in l-arg1 with l-arg2. .SU .EC l-arg1 is atomic. .OE provide any appropriate non-atomic S-expression. .EF .BF (rplaca l-arg e-arg) .RE l-arg. .SE replaces the CAR of l-arg with e-arg. .SU .EC l-arg is atomic .OE provide any S-expression. .EF .BF (rplacd l-arg e-arg) .RE l-arg. .SE replaces the CDR of l-arg with e-arg. .SU .EC l-arg is atomic .OE provide any S-expression. .EF .PG In addition to the compiled functions for operating on lists, there are several interpreted functions contained in the file "lspau.lsp" which are usually loaded with the interpreter. Note: It is difficult to know what to RETURN if an error occurs in one of these functions. Therefore the user should print out the entire context of the function before attempting to correct the error. No ERROR CONDITIONS are indicated for these functions because any errors would come from the compiled functions which these functions use. .BF (append l-arg1 l-arg2) .RE the result of appending l-arg2 to l-arg1. Copies l-arg1. .LA .EF .BF (apply f-arg l-arg) .RE the result of applying function f-arg to the arguments in the list l-arg. .LA .EF .BF (assoc e-arg l-arg) .RE the member of l-arg whose CAR is EQUAL to e-arg. .LA .EF .BF (copy l-arg) .RE a list with a structure identical to l-arg but with all new list nodes. .LA .EF .BF (last l-arg) .RE the last list node of l-arg. NOTE: not the last element. .br Example: (last '(a b c d)) = (d) .LA .EF .BF (length l-arg) .RE the number of toplevel elements in l-arg .LA .EF .BF (map f-arg l-arg) .RE the result of applying f-arg to the last non-NIL CDR of l-arg .SE applies f-arg t each CDR of l-arg. .LA .EF .BF (mapc f-arg l-arg) .RE f-arg apllied to the last element of l-arg. .SE applies f-arg to each element of l-arg. .LA .EF .BF (mapcar f-arg l-arg) .RE a list consisting of f-arg applied to each element of l-arg. .LA .EF .BF (maplist f-arg l-arg) .RE a list consisting of f-arg applied to each CDR of l-arg. .LA .EF .BF (subst e-arg1 e-arg2 e-arg3) .RE substitutes all occurances of e-arg2 in e-arg3 with e-arg1. .LA .EF .BF (replace a-arg1 e-arg1 e-arg2) .RE e-arg2. .SE directly replaces all occurances of a-arg with e-arg1 in e-arg2. .LA .EF .BF (reverse l-arg) .RE the reverse of l-arg. .LA .EF #-t- chap06.fmt 2997 ascii 15-Jan-84 13:51:16 #-h- chap07.fmt 1500 ascii 15-Jan-84 13:51:17 .so lisp.hdr .bp 1 .he ''PREDICATES'' .fo ''7-#'' 7.0 PREDICATES .BF (and e-arg1 e-arg2 ...) .RE t if all the e-argi are non-nil, otherwise nil. .SE and EVALuates the e-argi as it tests them so if one of the e-argi is nil the EVALuation stops. .FS .EC none .EF .BF (atom e-arg) .RE t if e-arg is one of the atomic data types, otherwise nil. .SU .EC none .EF .BF (eq e-arg1 e-arg2) .RE t if both e-arg1 and e-arg2 are atomic and of the same type, and have equal values. .SU .EC none .EF .BF (equal e-arg1 e-arg2) .RE t if either of the following conditions are met: .br .in +2 1) e-arg1 is atomic and (EQ e-arg1 e-arg2) .br 2) (and (equal (car e-arg1) (car e-arg2)) .ti +8 (equal (cdr e-arg1) (cdr e-arg2))) .in -2 .EC none .EF .BF (member e-arg1 e-arg2) .RE if e-arg1 is EQUAL to a top level member of e-arg2, then the elements of e-arg2 from that point on, otherwise nil. .SU .EC none .EF .BF (membq a-arg e-arg) .RE the same thing as member except the membq uses eq, not equal. .SU .EC none .EF .BF (null e-arg) .RE t if e-arg is equal to nil, otherwise nil. .SU .EC none .EF .BF (numberp e-arg) .RE t if e-arg is a number, otherwise nil. .SU .EC none .EF .BF (or e-arg1 e-arg2 ...) .RE nil if all of the e-argi are nil, otherwise t. OR EVALuates its arguments until one of them is non-nil, then EVALuation stops. .FS .EC none .EF .BF (stringp e-arg) .RE t if e-arg is a string, otherwise nil. .SU .EC none .EF .BF (symbolp e-arg) .RE t if e-arg is a symbolic name, otherwise nil. .SU .EC none .EF #-t- chap07.fmt 1500 ascii 15-Jan-84 13:51:17 #-h- chap08.fmt 1872 ascii 15-Jan-84 13:51:18 .so lisp.hdr .bp 1 .he ''EXECUTIONAL FORMS'' .fo ''8-#'' 8.0 EXECUTIONAL FORMS .PG This LISP provides the standard COND and PROG forms, but it also provides several other executional forms from structured programming which are not only neater than using GOs, but are faster. .sp (cond clause1 clause2 ...) .sp The clausei are of the form (cond expr1 expr2 ...). COND takes the clausei in sequence and EVALuates the cond. If it is non-NIL, then COND EVALuates the corresponding expri and returns the value of the last expri. CONDitionals in which none of the clausei have non-NIL conds do not cause an error. .sp (for init cond repeat expr1 expr2 ... exprn) .sp FOR is much like the RATFOR for-loop. It is best described by the alogorithm below: .sp .in +5 .nf for( eval(init) ; eval(cond) != nil ; eval(repeat) ) .in +2 for( i = 1 ; i <= n ; i = i + 1 ) .in +2 eval(expri) .in -4 .sp .in -5 .fi (go label) .sp GO performs a jump in a PROG. If label is atomic, then that label is searched for, otherwise it is EVALuated to yield a label. GO may branch outside of the currently executing PROG. .sp (prog varlist expr1 expr2 ...) .sp First PROG binds the elements of varlist to NIL. Then it sequentially EVALuates the expri. If a RETURN is exectuted in one of the expri then control immediately transfers out of the PROG. If a GO is executed then control tranfers back to the PROG and the label is searched for. If the label is not found then an attempt is made to GO to a label in a dynamically enclosing PROG. .sp (return val) .sp RETURN causes the currently executing PROG to exit and return val as its value. .sp (while cond expr1 expr2 ... exprn) .sp WHILE is similar to the while-loop in RATFOR. It is best described by the following algorithm: .sp .in +5 .nf while( eval(cond) != nil ) .in +2 for( i = 1 ; i <= n ; i = i + 1 ) .in +2 eval(expri) .in -4 .sp .in -5 .fi #-t- chap08.fmt 1872 ascii 15-Jan-84 13:51:18 #-h- chap09.fmt 4190 ascii 15-Jan-84 13:51:18 .so lisp.hdr .bp 1 .he ''INPUT/OUTPUT'' .fo ''9-#'' 9.0 INPUT/OUTPUT .PG As mentioned in the section under COMPILED FUNCTIONS, I/O CHANNELs look just like functions. I/O channels have the following form: .sp .in +5 .nf (ichannel . #nn) for an input channel , or (ochannel . #nn) for an output channel .sp .in -5 .fi .PG To use these channels as functions, they merely have to be referred to in a functional context. .bp 9.1 CHANNEL MANIPULATION .BF (close f-arg) .RE t if the close was successful, else nil. .SU .SE closes the channel specified by f-arg. .EC f-arg is not a channel specification. .OE provide t or nil .EF .BF (inpush f-arg) .RE t if f-arg is a valid channel, else nil. .SU .SE splices f-arg into the input stream. .EC f-arg is not a channel specification. .OE provide t or nil .EF .BF (open s-arg 'a-arg) .RE a channel to the file specified by s-arg, or nil if the file can't be accessed. .br a-arg may be either READ, WRITE or APPEND. .SU .EC s-arg describes a file which does not exist or is locked. .OE provide a channel specification. .EF .BF (create s-arg 'a-arg) .RE a channel to the file specified by s-arg, or nil if the file can't be created. .br a-arg may be either WRITE or APPEND. .SU .SE if a file with the same name already exists it will be overwritten. .EC s-arg describes a file which can't be created or is locked. .OE provide a channel specification. .EF .bp 9.2 READing .sp 2 READ MACROS .PG Read macros allow you to define special characters for the reader by attaching code to the atom for the character. For example, if we wanted to define a new character for (quote) besides the single-quote character we could use: .sp .ce (setq \^ (read_macro (list 'quote (read)))) .sp When "ratom" encounters the character '^' it will execute the code after "read_macro". .sp 2 META PARENTHESES .PG Meta parentheses ('[' and ']') may be used to simplify entering nested S-expressions. The reader notes each '[' in the input and, when it encounters a ']', will match backward until it finds a '[' or until it reaches the top level. User invocation of "read" from the interpreter is always at top level, even if it is inside a function definition. For example: .sp 1 .in +8 (a b (c (d] .sp 1 and .sp 1 (a b [c (d]) .sp 1 are the same as .sp 1 (a b (c (d))). .in -8 .bp .BF (getlin f-arg) .RE the next line of input from input channel f-arg. .br if f-arg == nil, STDIN is read. .br on end-of-file, returns nil. .SU .SE a line of input is read from f-arg. .EC f-arg is not a channel specification. .EF .BF (prompt s-arg f-arg) .RE a string read from f-arg. .br on end-of-file, returns nil. .SU .SE s-arg is written to f-arg as a prompt. .br a string is read from f-arg. .EC s-arg is not a string. .br f-arg is not a channel or nil. .OE provide a string or a channel. .EF .BF (ratom) .RE the next atom in the primary input stream. You can test for special characters by using the atoms lpar, rpar and dot. .SU .EC none .EF .BF (read) .RE the next S-expression in the input data stream. .SU .EC the next S-expression in the input stream is ill-formed. .OE restart LISP at the TOPLEVEL. .EF .BF (readch) .RE the symbolic constant whose PNAME is the next character in the input data stream. (readch does NOT return a string.) .SU .EC .OE restart LISP at the TOPLEVEL. .EF .bp 9.3 PRINTing .BF (patom a-arg) .RE a-arg .SE prints the atom a-arg on the on the primary output device. .SU .EC a-arg is not an atom. .EF .BF (print e-arg) .RE e-arg .SE prints the S-expression e-arg on the primary output device. .SU .EC none .OE consult the maintainer. PRINT should not cause errors. .EF .BF (putlin s-arg f-arg) .RE s-arg .SU .SE s-arg is written to f-arg. .br if f-arg == nil, STDOUT is used. .br if s-arg == nil, nothing is output. .EC s-arg is not a string or nil. f-arg is not a channel specification. .OE provide a string or channel. .EF .sp 2 .bp 9.4 LOADing Files .BF (load s-arg) .RE t .SE opens the device specified by s-arg and sets the input channel to that device channel. LOAD then goes into a READ-EVAL-PRINT loop until it READs nil. .SU .EC s-arg does not exist or is locked. an end-of-file is encountered before nil. .OE restart LISP at the TOPLEVEL. .EF #-t- chap09.fmt 4190 ascii 15-Jan-84 13:51:18 #-h- chap10.fmt 1897 ascii 15-Jan-84 13:51:19 .so lisp.hdr .bp 1 .he ''ERROR PROCESSING/DEBUGGING .fo ''10-#'' 10.0 ERROR PROCESSING/DEBUGGING .PG This LISP interpreter provides the user with the means to look at the context of an error, and in some cases to correct the erroneous computation and continue processing. There is also a facility for the user to cause a break in the computation, either in his code or from the terminal, in order to look at the context of processing. .PG Most of the errors in this LISP are handled by the EVAL function. The compiled functions check for errors, and pass back the atom --ERROR++ if one occurs (NOTE: this is not a legal atom). EVAL then checks for this error, and goes into the break package to allow the user to examine the context and correct the error. The error messages are printed by the routine in which the error occured. The user can supply a value in the BREAK package and EVAL will substitute that value for the one which should have been produced by the function which passed back the error. .PG Errors which are not handled in this manner are I/O errors or trying to RETURN or GO with no PROG in the context stack. These errors are non-recoverable. .BF (break) .RE whatever the user indicates. .SE this is also the routine used by the EVAL when error processing. BREAK goes into a READ-EVAL-PRINT loop and returns a value when the user types 'return s-expr'. BREAK evaluates the s-expr and then returns it. .SU .EC none .EF .BF (showforms {n-arg1 {n-arg2}}) .RE nil .SE PRINTs the forms on the context stack. It starts at the form n-arg1 forms back and PRINTs n-arg2 of them. Both paramters default to 1. .SU .EC none .EF .BF (showstack) .RE nil .SE PRINTs the CAR of each of the forms in the context stack. .SU .EC none .EF .BF (status) .RE a list with the following numbers: the # of list nodes available, the largest block of array space, the # of characters of string space left. #-t- chap10.fmt 1897 ascii 15-Jan-84 13:51:19 #-h- chap11.fmt 1164 ascii 15-Jan-84 13:51:19 .so lisp.hdr .bp 1 .he ''MISCELLANEOUS FUNCTIONS'' .fo ''11-#'' 11.0 MISCELLANEOUS FUNCTIONS .BF (cd s-arg) .RE t if the default directory could be changed to s-arg, else nil. .SU .SE the default directory is changed to s-arg. .EC s-arg is not a string. .EF .BF (eval e-arg) EVALuates e-arg. .in +5 .EC e-arg is neither an atom nor a function invocation. .br e-arg is a function invocation of an undefined function. .br e-arg is an unbound symbol. .EF .BF (exit) causes the interpreter to terminate. .in +5 .EC none .EF .BF (gensym) .RE a new symbol .EC none .EF .BF (oblist) .RE a list of all the symbols on the oblist. .SU .EC none .EF .BF (quote 'e-arg) .RE e-arg .EC none .EF .BF (sh s-arg) .RE t if a shell could be spawned, else nil. .SE an instance of the software tools shell is located using the standard search path and is spawned, and fed s-arg as a command. .br if s-arg is nil, the shell will prompt for commands. .SU .EC none .EF .BF (spawn s-arg) .RE t if the (software tools) command could be spawned, else nil. .SE the executable program specified by the first word of s-arg is located using the standard search path and spawned. .SU .EC none .EF #-t- chap11.fmt 1164 ascii 15-Jan-84 13:51:19 #-h- chap12.fmt 7698 ascii 15-Jan-84 13:51:20 .so lisp.hdr .bp 1 .he ''LISP OBJECTS IN MEMORY'' .fo ''12-#'' 12.0 LISP OBJECTS IN MEMORY .PG The data base is contained in three large arrays: LISTS for dotted pairs, STRNG for character strings, and ARRAYS for array blocks. .PG Storage for LISTS is allocated in 3-word nodes from the available storage list. LISTS nodes are collected by the garbage collector when no more nodes are left on the available storage list. .ne 9 .sp 2 .nj .nf .ce 4 +--------+--------+----------------+----------------+ | aux | atom | car | cdr | | field | field | field | field | +--------+--------+----------------+----------------+ .sp 2 .fi .ju .ce FIG 12-1 The fields of a node .PG Nodes occupy the space required for 3 integers and have 4 fields as in FIG 12-1. The aux field is used by the garbage collector for marking and tagging. The atom field is used for atomic nodes to indicate which type of atom they are. This field is zero for list nodes. The car and cdr fields contain the obvious information for list nodes and information about the atom for atomic nodes. All further pictorial representations of list nodes will omit the aux and atom fields. .PG STRNG storage is allocated in a heap fashion and is non-recoverable. Blocks from ARRAYS are allocated to the user's arrays and can be returned by the user when they are no longer in use. .sp 2 12.1 ATOMIC NODES .PG The LISP interpreter handles four basic types of data: symbols, strings, numbers, and subrs. These four basic types can then be combined into dotted pairs and lists. This section describes how each of these data types is represented with respect to the main data array LISTS. .sp 2 12.1.1 SYMBOLS .PG Symbols are the most basic type of LISP data. When the READ function encounters an expresion such as (a . b) then the actual data which it puts in the dotted pair is a unique address in the array LIST. This is the address of a list node as below: .ne 29 .nf .nj .sp 2 .in +4 +-+-+---+---+ | |1| . | . | +-+-+-|-+-|-+ .in +6 | | | V | +-----+---+ +---+---+ +-----+---+ +---+---+ | |VALUE| .---->| . | .---->|PNAME| .---->| . | | | +-----+---+ +-|-+---+ +-----+---+ +-|-+---+ | | | +----------------->| | .in +19 V V .in -3 value of string the atom node .in -22 .in -4 .sp 2 .fi .ju .ce FIG 12-2 A symbol node and its property list .PG If the READ function ever sees this symbol again it will recognize it (by checking the PNAME) and use the same unique node address. .sp 2 12.1.2 STRINGS .PG Each time the READ function encounters a double quote (") it will assume the beginning of a string and the string will end with the next ("). After it reads the string it will allocate enough storage in the array STRNG to hold the string and make an entry in the array LISTS as follows: .ne 9 .nf .nj .sp 3 .ce 3 +--------+---------+------------------+------------------+ | | 8 | string length | starting index | +--------+---------+------------------+------------------+ .sp 3 .fi .ju .ce FIG 12-3 A string node .PG String length is the length of the string and starting position is the starting index of the string in the array STRNG. .sp 2 12.1.3 NUMBERS .PG This LISP system only handles foating point numbers When the function RATOM encounters a number it will make an entry in the array LISTS as follows .ne 9 .nf .nj .sp 3 .ce 3 +--------+--------+----------------+----------------+ | | 4 | floating point number | +--------+--------+----------------+----------------+ .sp 3 .fi .ju .ce FIG 12-4 A number node .sp 2 12.1.4 SUBRs .PG SUBRs are used to hold the entry points of compiled functions, I/O channel numbers, and the addresses of array blocks. SUBRs cannot be read in from the interpreter; they are only created inside the interpreter. When printed, SUBRs look like #nnnnn. .ne 8 .sp 3 .nf .nj .ce 3 +--------+--------+-----------------+----------------+ | | 2 | integer | | +--------+--------+-----------------+----------------+ .sp 3 .fi .ju .ce FIG 12-5 A SUBR node. .sp 2 12.2 LIST NODES .PG The basic data structure element of LISP is a pair of words, called a dotted pair. The function CONS allocates a pair of words and initializes their values. Here are some examples of dotted pairs: .ne 10 .sp 3 .nf .nj .ce 3 +---+---+ +---+---+ +---+-----+ | a | b | | 1 | 4 | | a | 1.2 | +---+---+ +---+---+ +---+-----+ .sp 3 .fi .ju .ce FIG 12-6 Examples of dotted pairs .PG The typographical representations of these pairs are (a.b), (1 . 4), and (a . 1.2) respectively. .PG Dotted pairs can contain dotted pairs as illustrated below: .ne 25 .sp 2 .nf .nj .in +8 +---+---+ +---+---+ | a | . | | . | . | +---+-|-+ +/--+--\+ .in +6 | / \ V / \ .in -4 +---+---+ V V | 1 | 4 | +---+---+ +---+---+ +---+---+ | a | b | | 1 | . | .in +21 +---+---+ +---+--\+ .in +21 \ .in +1 V .in -4 +---+---+ | 4 |NIL| +---+---+ .in -41 .in -8 .sp 2 .fi .ju .ce FIG 12-7 Examples of combinations of dotted pairs. .PG These are represented typographically as (a. (1 . 4)) and ((a . b) . (1 . (4 . NIL))) respectively. The symbol NIL is equivalent to the empty list, (). In the interpreter NIL is the zero pointer. .PG With NIL we can create a linked list, as seen below. .ne 15 .sp 2 .nf .nj .ce 3 +---+---+ +---+---+ +---+---+ +---+---+ | a | .---->| b | .---->| c | .---->| d |NIL| +---+---+ +---+---+ +---+---+ +---+---+ .sp 2 .fi .ju .ce FIG 12-8 An example of a linked list .PG This is represented by (a . (b . (c . (d . NIL)))); it can also be written as (a b c d) in list notation. As with dotted pairs we can have lists in lists and we can mix the two as below: .ne 25 .sp 2 .nf .nj .in +4 +---+---+ +---+---+ +---+---+ +---+---+ | . | .---->| c | .---->| d | .---->| . |NIL| +-|-+---+ +---+---+ +---+---+ +-|-+---+ .in +2 | | V V .in -2 +---+---+ +---+---+ +---+---+ | a | .---->| b |NIL| | . |NIL| +---+---+ +---+---+ +-|-+---+ .in +38 | V .in -2 +---+---+ +---+---+ | e | .---->| f |NIL| +---+---+ +---+---+ .in -36 .in -4 .sp 2 .fi .ju .ce FIG 12-9 Lists inside lists .PG Which prints as ((a b) c d ((e f))) and .ne 20 .sp 2 .nf .nj .in +16 +---+---+ +---+---+ +---+---+ | a | .---->| . | .---->| d |NIL| +---+---+ +-|-+---+ +---+---+ .in +14 | V .in -2 +---+---+ | b | c | +---+---+ .in -12 .in -16 .sp 2 .fi .ju .ce FIG 12-10 Mixing dot and list notation .sp which prints as (a (b . c) d). .sp 2 12.2.1 ARRAY BLOCKS .PG The TAG and SIZE fields are used by the storage allocating and deallocating routines. N is the dimensionality of the array and the Li and Ui are the upper and lower bounds for each of these dimensions. .PG Array blocks are used in implementing arrays in LISP. Each array is laid out as illustrated in FIG 12-11. .ne 25 .sp 2 .nf .nj +-----+-----+-----+-----+-----+--------+-----+-----+---------+ | TAG |SIZE | N | L1 | U1 | ... | Ln | Un | | +-----+-----+-----+-----+-----+--------+-----+-----+ | | | | array data | | | +------------------------------------------------------------+ .sp 2 .fi .ju .ce FIG 12-11 An array block #-t- chap12.fmt 7698 ascii 15-Jan-84 13:51:20 #-h- chap13.fmt 5680 ascii 15-Jan-84 13:51:21 .so lisp.hdr .de DD .in +4 .cc , . . . ,cc . .in -4 .en .bp 1 .he ''RECURSION'' .fo ''13-#'' 13.0 RECURSION .PG There are two major obstacles to having recursion in FORTRAN: .sp .in +5 .nf .ti -3 1) FORTRAN calling conventions (at the machine level) do not handle recursive calls. .ti -3 2) FORTRAN syntax does not allow recursive calls. .sp .in -5 .fi .PG In order to circumvent these difficulties we must provide a way to implement features that some languages have (i.e. stacks and recursion) in FORTRAN. To this end when the recursion package is loaded with the interpreter there are two fixed length stacks, one for saving return addresses and the other for saving values before a direct or indirect recursive call. .PG The second stack is a very simple data stack accessed by the two subroutines PSHA and POPA which are called as follows: .ne 15 .sp 2 .nf .nj CALL PSHA(I) # Pushes the contents of the variable I onto # the data stack. I = POPA() # Return the value on the top of the stack. .sp 2 .fi .ju .ce FIG 13-1 Using the data stack .sp .PG The first stack is considerably more difficult to implement and must only be accessed by the interpreter through the provided subroutine calls. The subroutines which implement this stack are highly machine dependent and so are coded in assembly language for the HP 1000. It should not be difficult for a programmer who is familiar with the FORTRAN calling conventions on another machine to implement them elsewhere. Let us examine what a function call looks like in FTN4 on the HP 1000. .ne 35 .sp 2 .nf .nj I = FUNC(IPARM1,IPARM2) .DD .sp In Assembly .sp JSB FUNC DEF *+3 DEF IPARM1 DEF IPARM2 .DD ARG1 NOP Formal paramters ARG2 NOP FUNC NOP Function entry point JSB .ENTR '.ENTR' is a micro code instrtuction to fetch DEF ARG1 paramter address. .sp 2 .fi .ju .ce FIG 13-2 An example function call in .ce machine language on the HP 1000 .PG We use this knowledge to write a subroutine which, when called as the first executable statement of a FORTRAN subroutine, will save the return address on a stack to be referenced when the function to returns to the caller. This subroutine is ENTRY. Its calling sequence is shown below: .ne 25 .sp 2 .nf .nj INTEGER FUNCTION FUNC() {specification statements} CALL ENTRY .DD I = JCALL(FUNCF) .DD .sp 2 .fi .ju .ce FIG 13-3 Patching a FORTRAN function call for recursion. .PG JCALL is another of the recursion primitives. It performs an indirect function call. The variable FUNCF must be in a common block and needs to be initialized to the address of the entry point of FUNC. This introduces another recursion primitive, ADDRS which returns the entry point of an external reference as seen in FIG 13-4. .PG In order to pop the stack when returning the recursive subroutine must make a call to EXIT which pops the stack and jumps to that address. EXIT also place a value in whatever register is used for returning functional values. The calling sequence for EXIT is shown in FIG 13-5 .ne 27 .sp 2 .nf .nj PROGRAM MAIN COMMON FUNCF INTEGER FUNCF EXTERNAL FUNC INTEGER ADDRS FUNCF = ADDRS(FUNC) .DD I = FUNC() .DD .sp 2 .fi .ju .ce FIG 13-4 Initializing the entry address .ce of a recursive function .sp 3 .ne 11 .sp 2 .nf .nj .DD CALL EXIT(IVAL) .sp 2 .fi .ju .ce FIG 13-5 Returning from a recursive function. .PG Two things are apparent from the calls to JCALL and EXIT. First is that no parameters are passed to the subroutine and second that it only returns integers. The latter is really no problem as all of the functions pass back LISP values which are represented as integers in FORTRAN. To deal with the first the interpreter uses a BLOCK COMMON to pass the parameters among the functions. Its format can be seen below: .ne 25 .sp 2 .nf .nj FORTRAN statements .sp COMMON /REGCM/ AREG,BREG,CREG,DREG,EREG INTGER AREG,BREG,CREG,DREG,EREG .sp In memory .sp +------+------+------+------+------+ | areg | breg | creg | dreg | ereg | +------+------+------+------+------+ .sp 2 .fi .ju .ce FIG 13-6 Paramter passing through common .PG It is the responsibility of the called function to retrieve these values and to save them on the data stack before any recursive calls. To illustrate, an example of a recursive coding of factorial is given in FIG 13-7. .PG From this simple example we can see some of the programming considerations which arise when using this method. The first is that calling sequences are altered. The calling routine no longer puts its parameters in the call statement and has them passed to the function; the new functions are called by value and so the called function cannot alter any variables in the calling routine; the programmer must decide what values he has to save when making a recursive call. Also he must remember to pop off the stack anything which he pushes on. The last consideration is that all recursively programmed functions must return explicitly. The common practice of letting a subroutine return by encountering the end will completely disrupt the stack. .ne 35 .sp 2 .nf .nj INTEGER FUNCTION FACT() COMMON FACTF INTEGER FACTF COMMON /REGCM/ AREG,BREG,CREG,DREG,EREG INTEGER AREG,BREG,CREG,DREG,EREG INTGER I,J INTEGER POPA CALL ENTRY I = AREG ! Fetch the paramater IF(I .EQ. 0) CALL EXIT(1) ! Ground Clause CALL PSHA(I) ! Save the argument AREG = I-1 ! Pass the argument for the recursive call J = JCALL(FACTF) I = POPA() CALL EXIT(I*J) END .sp 2 .fi .ju .ce FIG 13-7 An example of a recursive factorial .sp .PG Two recursion primitives which are not illustrated here are GETS and PUTS which get and restore the stack pointer for the return address stack. These two routines are used in implementing GOs and RETURNs in PROGs. #-t- chap13.fmt 5680 ascii 15-Jan-84 13:51:21 #-h- chap14.fmt 5867 ascii 15-Jan-84 13:51:22 .so lisp.hdr .bp 1 .he ''ADDING NEW FUNCTIONS TO LISP'' .fo ''14-#' 14.0 ADDING NEW FUNCTIONS TO LISP .PG One of the dividends gained by writing LISP in a high level language is that it is easy to modify and extend. This section is designed for the programmer who wants to add new compiled functions to the interpreter or to customize the ones already included. Together with the preceding two section; this section should give the programmer all the information he needs about the conventions which need to be followed by SUBRs, FSUBRs, and LSUBRs. Also included at the end of this section are detailed descriptions of the coding of three functions which are now part of the interpreter: DMEMBER(SUBR), LIST(FSUBR), and MAX(LSUBR). .sp 2 14.1 MEMORY OVERLAYS .PG This section is not nessesary for programmers who are working with LISP on a large machine where overlays are not nessesary. However on any 16-bit machine, overlaying will most certainly be needed to re-host LISP. .PG The allocation of memory in LISP is shown if FIG 14-1. As the diagram indicates the data base arrays, EVAL and any functions which call EVAL, either directly or indirectly through the BREAK function need to kept in main memory. The reason for this is that if a function residing in an overlay were to call EVAL, EVAL might have to bring in another overlay to execute another compiled function. This would overwrite the function currently executing and would produce extremely unpredictable results when EVAL tried to return there. .ne 35 .sp 2 .nf .nj .ce 100 +----------------------+ | data base arrays | | LISTS, STRNG, and | | ARRAYS | +----------------------+ | EVAL | +----------------------+ | function which | | call EVAL | +----------------------+ | | | memory overlay | | area | | | +----------------------+ .ce 0 .sp 2 .in +4 +-----------------------+----------------------+ | | | | OVERLAY | OVERLAY |... | 1 | 2 | | | | +-----------------------+----------------------+ .in -4 .sp 2 .fi .ju .ce FIG 14-1 Memory allocation in LISP. .sp 2 14.1.1 FUNCTION DEFINITIONS FOR OVERLAYED FUNCTIONS .PG Functions which reside in overlays do not have definitions such as those given in COMPILED FUNCTIONS. Rather they look, when printed, like this: .sp .ti +5 (type . (#m . #nnnnn)) .sp where 'type' is SUBR, FSUBR or LSUBR; 'm' is the number of the overlay where the function resides, and 'nnnnn' is the entry point of the function. This form of function definition is recognized by EVAL and when it is encountered EVAL calls in the appropriate overlay before it jumps to the entry point. .sp 2 14.1.2 MEMORY OVERLAY INITIALIZATION .PG At link time the entry point address of the functions residing in overlays are not accessable to the the main program. If they were, these routines would be loaded with the main program. We need a way to bring in a memory overlay and start it executing at the begining, where we will place the code to initialize the property lists of the functions residing in that overlay. This is done by setting a flag in a block common which the memory overlay can examine. If it is true then it starts the initialization routine; otherwise it jumps back into the main program. .sp 2 14.1.3 LODSG .PG LODSG is the subroutine which handles bringing in the memory overlays. The calling sequence for LODSG is .sp .ti +5 call lodsg( iseg, ip1, ip2, ip3, ip4, ip5) .sp where ISEG in the number of the overlay to bring in. The IPi are 5 parameters which are passed to the overlay through a common block. The first one, IP1, is reserved for telling the overlay whether or not to perform initialization of the functions contained in that overlay. .PG LODSG is called most often by EVAL but it is also called by functions which use READ or PRINT, as these functions are contained in overlays. .sp 2 14.2 LISP INITIALIZATION .PG Before LISP can start the TOP LEVEL it must initialize the data base. This includes initialization of the free storage list, initiailization of the STRNG heap, initialization of the array block available storage list, setting common variables to the addresses of atoms which are used in the interpreter (i.e. VALUE, --ERROR++, BINDING, etc.), and putting the entry points of compiled functions on their property lists. This initialization is performed in the subroutine LSPIN. Anyone who wants to add new functions to LISP must modify and recompile LSPIN to make sure that he can access his new functions once he loads them in. In the main program, the programmer makes the following changes to LSPIN: .sp .in +5 .nf 1) Add the new function to the EXTERNAL statement. 2) Add a line of code similar to .ti +5 i = makfn( "your_name_here", nchar, type, addrs(func)) .sp .in -5 .fi where NCHAR is the number of characters in the name, TYPE is QSUBR,QFSUBR, or QLSUBR, and func is the name of the function being added. .PG To add a new function to a segment, say segment "nn", we have to change the routine LISnn. We have to make the following changes: .sp .in +5 .nf 1) Add the new function to the EXTERNAL statement in LISnn 2) Add a new line of code similar to .ti +5 i = makNN( "your_name_here", nchar, type addrs(func)) .sp .in -5 .fi where the arguments to MAKnn are the same as those to MAKFN. .PG If the programmer wants to add a new overlay to LISP then he must add a line .sp .ti +5 call lodsg( nn, -1, 0, 0, 0, 0) .sp to LISIN, where "nn" is the number of the new overlay. .sp 2 14.3 PROGRAMMING EXAMPLES .sp 2 14.3.1 AN EXAMPLE SUBR -- DMEMBER .so dmember.fmt .sp 2 14.3.2 AN EXAMPLE FSUBR -- LIST .so list.fmt .sp 2 14.3.3 AN EXAMPLE LSUBR -- MAX .so max.fmt #-t- chap14.fmt 5867 ascii 15-Jan-84 13:51:22 #-h- apndxa.fmt 628 ascii 15-Jan-84 13:51:23 .so lisp.hdr .bp 1 .he ''APPENDIX A -- AN EXAMPLE SESSION'' .fo ''A-#'' .PG This section gives an example terminal session with LISP. It demonstrates some of the basic facilities of LISP which the new user will need almost immediately. These are: LOADing files of function definitions, editing function definitions, and correcting an erroneous computation. The editor provided was taken from FRANZ LISP, which took it from BBN LISP. It is very similar to editor described in THE UCI LISP MANUAL, except that it does not have all the features of that editor. The editor is explained more fully in APPENDIX B. .sp .so session.fmt #-t- apndxa.fmt 628 ascii 15-Jan-84 13:51:23 #-h- apndxb.fmt 3886 ascii 15-Jan-84 13:51:23 .so lisp.hdr .bp 1 .he ''The LISP editor'' .fo ''B-#'' .nf .nj ; EDITOR FROM BBN-LISP C. 1968 ; (TRANSCRIBED BY R. FATEMAN FOR UNIX LISP, OCT., 1977) ; (MODIFIED AND ENHANCED BY P. PIFER, MAY, 1978) ; (CORRECTED AGAIN BY R. FATEMAN FOR VAX UNIX LISP, DEC., 1978) ; (CLEANED UP, COMMENTED AND COMPILED BY J. FODERARO, AUG., 1979) ; ( ... FIXED BUG IN ^ COMMAND) ; (MODIFIED BY C. P. DOLAN FOR HACK LISP, AUG 1981) ; FIXED BUG IN (R ...) COMMAND ; FIXED BUG IN THE EXECUTION OF MACROS WITH NO PARAMTERS ; ; The following is a list of all the commands which have been ; debugged and checked out for use with the LISP interpreter: ; ; OK -- ends the editing session ; E from -- makes a call to EVAL with form ; p -- prints the current expression with the ; current print level ; PP -- pretty prints the entire CE ; MARK -- marks the current expression for reference later ; < -- returns to last last CE MARKed ; << -- same as < but erases the MARK ; ^ -- returns to top level expression ; POFF -- sets the printflag off ; PON -- sets the printflag on ; n -- n > 0 makes the nth expression of the CE the current expression ; n = 0 goes up one level ; (S var [cmnds]) -- sets var to the CE after executing the cmnds ; (R e1 e2) -- replaces e1 with e2 throughout the CE ; (E form) -- same as E form ; (n e1 e2 ... em) -- replaces the nth member of the CE with ; e1 e2 ... em ; (-n e1 e2 ... em) -- inserts e1 e2 ... em before the nth member of ; the CE ; (I n e1 e2 ... em) -- same as (n e1 e2 ... em) except that the ei's ; are evaluated first ; (N e1 e2 ... em) -- concatenates the ei's at the end of the CE ; (P n m) -- print the nth member of the CE to level m ; (PL n) -- set the print level to n ; (BI n m) -- inserts a left paren before the nth element of the CE ; and a right paren after the mth. For example: ; (a b (c d e) f g) --(BI 2 4)--> (a (b (c d e) f) g) ; (BO n) -- deletes the parentheses around the nth element of the CE. ; For example: ; (a b (c d e) f g) --(BO 2)--> (a b c d e f g) ; (LI n) -- inserts a left paren before the nth element of the CE ; and adds a right paren at the enf of the CE. For example: ; (a b (c d e) f g) --(LI 2)--> (a (b (c d e) f g)) ; (LO n) -- removes the left paren before the nth element of the CE, ; deleting the rest of the CE. For example: ; (a b (c d e) f g) --(LO 2)--> (a b c d e) ; (RI n m) -- insert a right paren after the mth element of the nth ; element of the CE. For example: ; (a (b c d e) f g) --(RI 2 3)--> (a (b c d) e f g) ; (RO n) -- removes the right paren from the nth element of the CE ; and places it at the end of the list For example: ; (a b (c d e) f g) --(RO 3)--> (a b (c d e f g)) ; (F pat) -- finds the 'pat' in the current expression if 'pat' ; is on the top level. ; (F pat n) -- finds the nth occurrence of 'pat' in the expression ; (F pat N) -- finds the 'pat' in the current expression ; but assures that the edit chain will change ; (D name cmd1 cmd2 ...) -- defines a macro which when envoked by ; name, executes the cmdi ; (D (name) varspec cmd1 cmd2...) -- defines a macro with parameters ; which are substituted before ; cmdi are executed ; varspec has two forms: 1) var -for a sigle paramter ; 2) (var1 var2 ...) for several ; (M name cmd1 cmd2 ...) -- same a D but defines global macros ; or ; (M (name) varspec cmd1 cmd2 ...) ; #-t- apndxb.fmt 3886 ascii 15-Jan-84 13:51:23 #-h- apndxc.fmt 1187 ascii 15-Jan-84 13:51:24 .so lisp.hdr .bp 1 .he ''Functions for Accessing Atomic Nodes from RatFor'' .fo ''C-#'' .fi .ju .PG This appendix contains descriptions of functions for accessing the fields of atomic nodes. It is much easier for the RatFor programmer, adding new compiled functions to LISP, to use these routines than to directly access the array LISTS. .sp .in +5 atom(i) returns t if 'i' is an atomic node, else nil. .sp chget( strg, i) returns the 'i'th character in the string "strg". .sp gtent(i) returns the integer field of a SUBR. .sp gtval(i) returns the value of a symbolic node. .sp heap() returns the address of a new node. .sp maksg( buf, n) takes a Hollerith string in 'buf' of length 'n' and creates a LISP string. .sp mknum(x) returns a LISP number with 'x' as its floating point field. .sp mksbr(adr) returns a LISP SUBR with 'adr' as its integer field. .sp numbp(i) returns t if 'i' is a LISP number, else nil. .sp setvl( atm, i) sets the value of the symbol 'atm' to 'i'. .sp strln(str) returns the length of the string 'str'. .sp strgp(i) returns t if 'i' is a string, else nil. .sp subrp(i) returns t is 'i' is a SUBR, else nil. .sp symbp(i) returns t if 'i' is a symbol, else nil. #-t- apndxc.fmt 1187 ascii 15-Jan-84 13:51:24 #-h- dmember.fmt 1786 ascii 15-Jan-84 13:51:24 .sp 3 .nf .nj # Note first that the FORTRAN names have only five characters. # This five character name is the one that goes in the EXTERNAL # statement. integer function dmemb() # The function (DMEMBER a-arg l-arg) returns T if a-arg occurs # anywhere in l-arg, otherwise NIL. # Include the necessary common blocks. include lspcm LISPVAL ele,lst # These are the two parameters. LISPVAL jcall # This is the indirect function caller. LISPVAL val # This will hold the return value. LISPVAL atom # A LISP function to test for atoms. LISPVAL eq # A LISP function to test for equality. # Save the return address; this is a recursive function. ENTRYPOINT ele = areg # Get the parameters from the common. lst = breg # If ele is eq to lst then we have a match and we can return. # NOTE that we use both the normal FORTRAN value return mechanism, # "dmemb = T", and the recursive return method. On machines which # stack return addresses, we can use the hardware stack for returns. if( eq( ele, lst) == T ) { .in +2 dmemb = T RETURN_VALUE(T) .in -2 } else if( atom( lst) == NIL ) # If lst is not an atom, { .in +2 PUSH(ele) # Save the arguments on the data stack. PUSH(lst) areg = ele # Set up the parameter passing. breg = car(lst) val = jcall( dmembf) # Make the recursive call. lst = POP # Retrieve the items we pushed. ele = POP # If we got a non-NIL result on the last call then we can stop. if( val <> NIL ) { .in +2 dmemb = val RETURN_VALUE(val) .in -2 } areg = ele # Otherwise try the CDR. breg = cdr(lst) val = jcall( dmembf) dmemb=val RETURNVALUE(val) .in -2 } else # If lst is atomic then return NIL. { .in +2 dmemb = NIL RETURN_VALUE(NIL) .in -2 } end .fi .ju #-t- dmember.fmt 1786 ascii 15-Jan-84 13:51:24 #-h- list.fmt 1028 ascii 15-Jan-84 13:51:25 .sp 3 .nf .nj # This is the function LIST in HACK LISP. Since it takes an indefinite # number of arguments it is implemented as an FSUBR. integer function list() include lspcm LISPVAL last, arglst, iele, eval integer n ENTRYPOINT # Save the entry point arglst = areg # Get the argument list # Ground clause if( arglst == NIL ) { .in +2 list = NIL RETURN_VALUE(NIL) .in -2 } # Instead of choosing a recursive implementation we will keep track # of the end of the list. list = cons( NIL, NIL) last = list while( arglst <> NIL ) { .in +2 PUSH(list) # Save these values PUSH(last) PUSH(arglst) # Any call to EVAL is potentially recursive areg = car(arglst) # Set up the argument to EVAL iele = eval() arglst = cdr(POP) # Retrieve the stacked values last = POP list = POP # Add the new element to the list. n = RPLACA( last, iele) if( arglst == NIL ) .ti +2 break n = RPLACD( last, cons( NIL, NIL)) last = cdr(last) .in -2 } RETURN_VALUE(list) # return the value. end .fi .ju #-t- list.fmt 1028 ascii 15-Jan-84 13:51:25 #-h- max.fmt 1043 ascii 15-Jan-84 13:51:25 .nf .nj # The function MAX is called maxx in FORTRAN to avoid conflict with # the FORTRAN intrinsic function integer function maxx() # MAX take an indefinite number of arguments and is implemented as # an LSUBR include lspcm LISPVAL mknum # A function for constructing LISP numbers LISPVAL iargl # This is the argument list LISPVAL NUMBERP real numvl,x iargl = areg # Get the argument list ab = -1.0e38 while( iargl <> NIL ) { .in +2 # Check to make sure the arguments are all right # If we get an error, we merely pass the ERROR value # back to eval and print a message. if( NUMBERP( car( iargl)) == NIL ) { .in +2 maxx = QERROR call errlg( ARITH_ERROR, NUMERIC_VALUE) return .in -2 } # Get the next argument. NUMVL extracts the floating-point # number from a LISP number. x = numvl( car(iargl)) if( x > ab ) # Test the element. .in +2 ab = x .in -2 iargl = cdr(iargl) # Step to the next argument. .in -2 } maxx = mknum(ab) # Return the largest value found return end .fi .ju #-t- max.fmt 1043 ascii 15-Jan-84 13:51:25 #-h- session.fmt 3135 ascii 15-Jan-84 13:51:26 .nf .nj % lisp ; Here we load in the standard interpreted functions. -->(load "lspau.lsp") zerop onep replace copy (mapc mapcar maplist map) append assoc reverse length subst last nil "lspau.lsp" loaded t ; Now we try to make a simple recursive definition of factorial. ; This definition has two errors. The author originally only intended ; the first very simple error, but the second error demonstrates ; how to change the definition of a function while it is ; executing and to continue computation -->(defun fact (i) .in +5 (cond ((eq i 0) i) ; This is the simple error. .in +19 ; It should read ((eq i 0) 1) .in -12 ; This error is more sublte and cause a break in ; execution. (t (times (i (fact (sub1 i))))) .in -9 )) .in -3 fact ; Test out the ground case of the function. -->(fact 0) 0 ; Wrong answer ; We only bring in the editor at this point because the editor ; is very large. -->(load "edit.lsp") t 3 10 nil t t nil (err dtpr drain errset bcdp putd getd def) (subr #3.#569A0) (subr . #53B8C) (subr #3.#569A0) remedit subst printlevel editf dsubst editcoms edit1f edit2f edit2af edit4e editqf edit4f edit4f1 tconc editnth bpnt bpnt0 (bo bi lo li ri ro) subpair subpr ldiff editv nthcdr attach eprint edite editdefault editcom eprint1 assoc apply1 editp makefile appfile exec nil nil "edit.lsp" loaded t ; Edit the function -->(editf fact) edit ; The '&'s in the printout indicate non-atomic subexpressions (lambda (i) (cond & &)) #3 ; Go to the third element of the list (cond (& i) (t &)) #2 ; Move to the ground clause ((eq i 0) i) #(2 1) ; Replace the second element with '1' ((eq i 0) 1) #ok fact ; Try again. -->(fact 0) 1 ; So much for the ground case... -->(fact 3) ? Object not defined by EVAL. Provide any S-expression 3 ; This is a very confusing error message so we look at the ; names of all the functions which are currently pending. 1:(showstack) fact cond times i showstack nil ; We know of no function called 'I' so we look at the ; detailed picture. 1:(showforms) (i (fact (sub1 i))) nil ; Now we spot the extra parenthesis in our definition. ; We are going to edit "fact" on-line 1:(editf fact) edit (lambda (i) (cond & &)) ; Step down to one level above the offending expression #3 (cond (& 1) (t &)) #3 (t (times &)) #2 (times (i &)) ; We can seen that we have accidentally put parentheses around ; the arguments to "times". ; This powerful little command take both parentheses out ; from around the 2nd item. #(bo 2) (times i (fact &)) #ok fact ; Back in the break package we must return a value which ; will allow the computation to continue. 1:(showforms) (i (fact (sub1 i))) nil 1:(showforms 2 2) ; Looking at the two pending forms (times i (fact (sub1 i))) ; we see that the definition has indeed (i (fact (sub1 I))) ; been corrected. nil ; Returning 3 for the value of the offending expression, EVAL will ; then continue with the recursive call in the EVALuation of ; the previous form. 1:return 3 6 ; Voila; We get the correct answer. ; We can remove the editor and the garbage collector will reclaim ; most of the space. -->(remedit) gone -->(exit) .fi .ju #-t- session.fmt 3135 ascii 15-Jan-84 13:51:26 #-t- refman.ar 68440 ascii 15-Jan-84 14:28:21 #-h- rlib.ar 337387 ascii 15-Jan-84 15:29:20 #-h- lib.ar 181587 ascii 15-Jan-84 15:25:46 #-h- arsubs.r 3677 ascii 15-Jan-84 15:23:16 #-h- adefns 22 ascii 15-Jan-84 15:03:14 define(SEP_CHAR, '`') #-t- adefns 22 ascii 15-Jan-84 15:03:14 #-h- afetch 282 ascii 15-Jan-84 15:03:15 integer function afetch(buf, i, out) integer i, j character buf(ARB), out(ARB) for( j = 1 ; buf(i) != EOS ; i = i + 1 , j = j + 1 ) if( buf(i) == SEP_CHAR ) break else out(j) = buf(i) if( buf(i) != EOS ) i = i + 1 out(j) = EOS call fold(out) return( j - 1 ) end #-t- afetch 282 ascii 15-Jan-84 15:03:15 #-h- agetch 352 ascii 15-Jan-84 15:03:15 character function agetch(c, fd, size) character c filedes fd integer size(2) character getch # function(s) if( size(1) <= 0 & size(2) <= 0 ) c = EOF else if( getch( c, fd) == EOF ) { size(1) = 0 size(2) = 0 } else { size(2) = size(2) - 1 if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return(c) end #-t- agetch 352 ascii 15-Jan-84 15:03:15 #-h- agethd 561 ascii 15-Jan-84 15:03:15 integer function agethd(fd, buf, size, fsize) filedes fd character buf(MAXLINE) integer size(2), fsize(2) integer i integer agtlin, index # function(s) string hdr "#-h- " if( agtlin( buf, fd, fsize) == EOF ) return(EOF) for( i = 1 ; hdr(i) != EOS ; i = i + 1 ) if( buf(i) != hdr(i) ) break if( hdr(i) != EOS ) # bad format archive return(ERR) call skipbl( buf, i) # skip to name of module call scopy( buf, i, buf, 1) i = index( buf, ' ') buf(i) = EOS call fold(buf) i = i + 1 call ctodi( buf, i, size) # get size of module return(OK) end #-t- agethd 561 ascii 15-Jan-84 15:03:15 #-h- agtlin 376 ascii 15-Jan-84 15:03:15 integer function agtlin(buf, fd, size) character buf(MAXLINE) filedes fd integer size(2), n integer getlin # function(s) if( size(1) <= 0 & size(2) <= 0 ) return(EOF) n = getlin( buf, fd) if( n == EOF ) { size(1) = 0 size(2) = 0 } else { size(2) = size(2) - n if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return(n) end #-t- agtlin 376 ascii 15-Jan-84 15:03:15 #-h- aopen 814 ascii 15-Jan-84 15:03:16 filedes function aopen( name, fd, size) character name(FILENAMESIZE), file(FILENAMESIZE), module(FILENAMESIZE), buf(MAXLINE) integer i, fsize(2), size(2) integer afetch, agethd, equal # function(s) filedes fd filedes open # function(s) i = 1 if( afetch( name, i, file) <= 0 ) # bad name return(ERR) fd = open( file, READ) # open the main file if( fd == ERR ) return(ERR) fsize(1) = MAX_INTEGER fsize(2) = 0 if( afetch( name, i, module) <= 0) # flat archive { size(1) = MAX_INTEGER size(2) = 0 return (fd) } while( agethd( fd, buf, size, fsize) == OK ) if( equal( buf, module) == YES ) { if( afetch( name, i, module) <= 0 ) return(fd) fsize(1) = size(1) fsize(2) = size(2) } else call askip( fd, size, fsize) call close(fd) # ERROR if get here return(ERR) end #-t- aopen 814 ascii 15-Jan-84 15:03:16 #-h- askip 332 ascii 15-Jan-84 15:03:16 subroutine askip( fd, size, fsize) filedes fd integer size(2), fsize(2) character c character agetch # function(s) while( !( size(1) <= 0 & size(2) <= 0 ) ) { if( agetch( c, fd, fsize) == EOF ) break size(2) = size(2) - 1 if( size(2) < 0 ) { size(1) = size(1) - 1 size(2) = size(2) + 10000 } } return end #-t- askip 332 ascii 15-Jan-84 15:03:16 #-t- arsubs.r 3677 ascii 15-Jan-84 15:23:16 #-h- ds.r 12431 ascii 15-Jan-84 15:23:17 #-h- dsdef 748 ascii 15-Jan-84 15:03:48 # Defines for support library routines # Defines for memory management routines: define(DS_MEMEND,1) # pointer to end of memory define(DS_AVAIL,2) # start of available space list define(DS_CLOSE,8) # threshhold for close-fitting blocks define(DS_LINK,1) # link field of storage block define(DS_SIZE,0) # size field of storage block define(DS_OHEAD,2) # total words of overhead per block # Defines for symbol table routines: define(ST_LINK,0) # offset of link field in symbol table node define(ST_DATA,1) # offset of data field in symbol table node define(ST_HTABSIZE,29) # should be a prime number define(ST_SCANPOSN,arith(ST_HTABSIZE,+,1)) # offset to two word block # for context of table scan #-t- dsdef 748 ascii 15-Jan-84 15:03:48 #-h- dsinit 508 ascii 15-Jan-84 15:03:48 ## DSInit -- initialize dynamic storage space to `w' words. subroutine dsinit(w) integer w DS_DECL( Mem, 1) pointer t if( w < 2 * DS_OHEAD + 2 ) call error( "in dsinit: unreasonably small memory size" ) # set up avail list: t = DS_AVAIL Mem( t + DS_SIZE ) = 0 Mem( t + DS_LINK ) = DS_AVAIL + DS_OHEAD # set up first block of space: t = DS_AVAIL + DS_OHEAD Mem( t + DS_SIZE ) = w - DS_OHEAD - 1 # -1 for MEMEND Mem( t + DS_LINK ) = LAMBDA # record end of memory: Mem( DS_MEMEND ) = w return end #-t- dsinit 508 ascii 15-Jan-84 15:03:48 #-h- dsfree 800 ascii 15-Jan-84 15:03:49 ## DSFree -- return a block of storage to the available space list. subroutine dsfree(block) pointer block DS_DECL( Mem, 1) pointer p0, p, q integer n p0 = block - DS_OHEAD n = Mem( p0 + DS_SIZE ) q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA | p > p0 ) break q = p } if( q + Mem( q + DS_SIZE ) > p0 ) { call remark( "in dsfree: attempt to free unallocated block" ) return # do not attempt to free the block } if( p0 + n == p & p != LAMBDA ) { n = n + Mem( p + DS_SIZE ) Mem( p0 + DS_LINK ) = Mem( p + DS_LINK ) } else Mem( p0 + DS_LINK ) = p if( q + Mem( q + DS_SIZE ) == p0 ) { Mem( q + DS_SIZE ) = Mem( q + DS_SIZE ) + n Mem( q + DS_LINK ) = Mem( p0 + DS_LINK ) } else { Mem( q + DS_LINK ) = p0 Mem( p0 + DS_SIZE ) = n } return end #-t- dsfree 800 ascii 15-Jan-84 15:03:49 #-h- dsget 516 ascii 15-Jan-84 15:03:49 ## DSGet-- Get pointer to block of at least `w' available words. pointer function dsget(w) integer w DS_DECL( Mem, 1) pointer p, q, l integer n, k n = w + DS_OHEAD q = DS_AVAIL repeat { p = Mem( q + DS_LINK ) if( p == LAMBDA ) return(p) if( Mem( p + DS_SIZE ) >= n ) break q = p } k = Mem( p + DS_SIZE ) - n if( k >= DS_CLOSE ) { Mem( p + DS_SIZE ) = k l = p + k Mem( l + DS_SIZE ) = n } else { Mem( q + DS_LINK ) = Mem( p + DS_LINK ) l = p } return( l + DS_OHEAD ) end #-t- dsget 516 ascii 15-Jan-84 15:03:49 #-h- dsdump 683 ascii 15-Jan-84 15:03:49 ## DSDump -- Produce semi-readable dump of storage. subroutine dsdump(form) character form DS_DECL( Mem, 1) pointer p, t, q t = DS_AVAIL call remark( "** DYNAMIC STORAGE DUMP **" ) call putint( 1, 5, ERROUT) call putch( ' ', ERROUT) call putint( DS_OHEAD + 1, 0, ERROUT) call remark( " words in use" ) p = Mem( t + DS_LINK ) while( p != LAMBDA ) { call putint( p, 5, ERROUT) call putch( ' ', ERROUT) call putint( Mem( p + DS_SIZE ), 0, ERROUT) call remark( " words available" ) q = p + Mem( p + DS_SIZE ) while( q != Mem( p + DS_LINK ) & q < Mem( DS_MEMEND ) ) call dsdbiu( q, form) p = Mem( p + DS_LINK ) } call remark( "** END DUMP **" ) return end #-t- dsdump 683 ascii 15-Jan-84 15:03:49 #-h- dsdbiu 879 ascii 15-Jan-84 15:03:49 ## DSDBIU -- Dump contents of block-in-use. subroutine dsdbiu( b, form) pointer b character form DS_DECL( Mem, 1) integer l, s, lmax, t, j string blanks " " call putint( b, 5, ERROUT) call putch( ' ', ERROUT) call putint( Mem( b + DS_SIZE ), 0, ERROUT) call remark( " words in use" ) l = 0 s = b + Mem( b + DS_SIZE ) if( form == DIGIT ) lmax = 5 else lmax = 50 for( b = b + DS_OHEAD ; b < s ; b = b + 1 ) { if( l == 0 ) call putlin( blanks, ERROUT) if( form == DIGIT ) { call putint( Mem(b), 10, ERROUT) l = l + 1 } elif( form == LETTER ) { t = cvt_to_cptr(b) for( j = 1 ; j <= CHAR_PER_INT ; j = j + 1 ) { call putch( cMem(t), ERROUT) t = t + 1 } l = l + CHAR_PER_INT } if( l >= lmax ) { l = 0 call putch( '@n', ERROUT) } } if( l != 0 ) call putch( '@n', ERROUT) return end #-t- dsdbiu 879 ascii 15-Jan-84 15:03:49 #-h- mktabl 453 ascii 15-Jan-84 15:03:50 ## MkTabl -- Make a new (empty) symbol table. pointer function mktabl(nodsiz) integer nodsiz DS_DECL( Mem, 1) pointer st pointer dsget integer i st = dsget( ST_HTABSIZE + 3 ) # +3 for record of nodsiz # and 2-word block for scan context mktabl = st if( st != LAMBDA ) # allocation succeeded { Mem(st) = nodsiz for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { st = st + 1 Mem(st) = LAMBDA # null link } } return end #-t- mktabl 453 ascii 15-Jan-84 15:03:50 #-h- rmtabl 405 ascii 15-Jan-84 15:03:50 ## RmTabl -- Remove a symbol table, deleting all entries. subroutine rmtabl(st) pointer st DS_DECL( Mem, 1) integer i pointer bucket, node, walker bucket = st for( i = 1 ; i <= ST_HTABSIZE ; i = i + 1 ) { bucket = bucket + 1 walker = Mem(bucket) while( walker != LAMBDA ) { node = walker walker = Mem( node + ST_LINK ) call dsfree(node) } } call dsfree(st) return end #-t- rmtabl 405 ascii 15-Jan-84 15:03:50 #-h- sctabl 1247 ascii 15-Jan-84 15:03:50 ## ScTabl - Scan symbol table, returning next entry or EOF. integer function sctabl(table, sym, info, posn) pointer posn, table character sym(ARB) integer info(ARB) DS_DECL( Mem, 1) pointer bucket, walker integer nodsiz, i, j if( posn == 0 ) # just starting scan? { posn = table + ST_SCANPOSN # index to 2-word scan context block Mem(posn) = 1 # get index of first bucket Mem( posn + 1 ) = Mem( table + 1 ) # get pointer to first chain } bucket = Mem(posn) # recover previous position walker = Mem( posn + 1 ) nodsiz = Mem(table) repeat # until the next symbol, or none are left { if( walker != LAMBDA ) # symbol available? { i = walker + ST_DATA + nodsiz i = cvt_to_cptr(i) j = 1 while( cMem(i) != EOS ) { sym(j) = cMem(i) i = i + 1 j = j + 1 } sym(j) = EOS j = walker + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(j) j = j + 1 } Mem(posn) = bucket # save position of next symbol Mem( posn + 1 ) = Mem( walker + ST_LINK ) return(1) # not EOF } else { bucket = bucket + 1 if( bucket > ST_HTABSIZE ) break j = table + bucket walker = Mem(j) } } posn = 0 return(EOF) end #-t- sctabl 1247 ascii 15-Jan-84 15:03:50 #-h- stlu 638 ascii 15-Jan-84 15:03:51 ## STLu -- Symbol table lookup primitive. integer function stlu( symbol, node, pred, st) character symbol(ARB) pointer node, pred, st DS_DECL( Mem, 1) integer hash, i, j, nodsiz integer equal nodsiz = Mem(st) hash = 0 for( i = 1 ; symbol(i) != EOS ; i = i + 1 ) hash = hash + symbol(i) hash = mod( hash, ST_HTABSIZE ) + 1 pred = st + hash node = Mem(pred) while( node != LAMBDA ) { i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) == cMem(j) ) { if( symbol(i) == EOS ) return(YES) i = i + 1 j = j + 1 } pred = node node = Mem( pred + ST_LINK ) } return(NO) end #-t- stlu 638 ascii 15-Jan-84 15:03:51 #-h- delete 306 ascii 15-Jan-84 15:03:51 ## Delete -- Remove a symbol from the symbol table. subroutine delete( symbol, st) character symbol(ARB) pointer st DS_DECL( Mem, 1) integer stlu pointer node, pred if( stlu( symbol, node, pred, st) == YES ) { Mem( pred + ST_LINK ) = Mem( node + ST_LINK ) call dsfree(node) } return end #-t- delete 306 ascii 15-Jan-84 15:03:51 #-h- lookup 454 ascii 15-Jan-84 15:03:51 ## Lookup -- Find a symbol in the symbol table, return its data. integer function lookup(symbol, info, st) character symbol(ARB) integer info(ARB) pointer st DS_DECL( Mem, 1) integer i, nodsiz, kluge integer stlu pointer node, pred if( stlu( symbol, node, pred, st) == NO ) return(NO) nodsiz = Mem(st) kluge = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { info(i) = Mem(kluge) kluge = kluge + 1 } return(YES) end #-t- lookup 454 ascii 15-Jan-84 15:03:51 #-h- enter 807 ascii 15-Jan-84 15:03:51 ## Enter -- Place a symbol in the symbol table, updating if already present. integer function enter(symbol, info, st) character symbol(ARB) integer info(ARB) pointer st DS_DECL( Mem, 1) integer i, nodsiz, j integer stlu, length pointer node, pred pointer dsget nodsiz = Mem(st) if( stlu( symbol, node, pred, st) == NO ) { node = dsget( 1 + nodsiz + ( length(symbol) + CHAR_PER_INT ) / CHAR_PER_INT ) if( node == LAMBDA ) return(ERR) Mem( node + ST_LINK ) = LAMBDA Mem( pred + ST_LINK ) = node i = 1 j = node + ST_DATA + nodsiz j = cvt_to_cptr(j) while( symbol(i) != EOS ) { cMem(j) = symbol(i) i = i + 1 j = j + 1 } cMem(j) = EOS } j = node + ST_DATA for( i = 1 ; i <= nodsiz ; i = i + 1 ) { Mem(j) = info(i) j = j + 1 } return(OK) end #-t- enter 807 ascii 15-Jan-84 15:03:51 #-h- sdupl 419 ascii 15-Jan-84 15:03:52 ## SDupl -- Duplicate a string in dynamic storage space. pointer function sdupl(str) character str(ARB) DS_DECL( Mem, 1) integer i, k integer length pointer j pointer dsget j = dsget( ( length(str) + CHAR_PER_INT ) / CHAR_PER_INT ) sdupl = j if( j != LAMBDA ) { k = cvt_to_cptr(j) for( i = 1 ; str(i) != EOS ; i = i + 1 ) { cMem(k) = str(i) k = k + 1 } cMem(k) = EOS } return end #-t- sdupl 419 ascii 15-Jan-84 15:03:52 #-h- entdef 548 ascii 15-Jan-84 15:03:52 ## EntDef -- Enter a new symbol definition, discarding any old one. subroutine entdef( name, defn, table) character name(ARB), defn(ARB) pointer table integer lookup, enter pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "in entdef: no room for new definition" ) return end #-t- entdef 548 ascii 15-Jan-84 15:03:52 #-h- ludef 444 ascii 15-Jan-84 15:03:52 ## LuDef -- Look up a defined identifier, return its definition. integer function ludef( id, defn, table) character id(ARB), defn(ARB) pointer table DS_DECL( Mem, 1) integer i, j integer lookup pointer locn ludef = lookup( id, locn, table) if( ludef == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end #-t- ludef 444 ascii 15-Jan-84 15:03:52 #-h- rmdef 298 ascii 15-Jan-84 15:03:53 ## Rmdef -- remove symbol and definition from a symbol table subroutine rmdef(symbol, table) character symbol(ARB) pointer table integer lookup pointer text if (lookup(symbol, text, table) == YES) # remove (symbol,defn) pair { call dsfree(text) call delete(symbol, table) } return end #-t- rmdef 298 ascii 15-Jan-84 15:03:53 #-t- ds.r 12431 ascii 15-Jan-84 15:23:17 #-h- help.r 3554 ascii 15-Jan-84 15:23:20 #-h- defns 344 ascii 15-Jan-84 15:04:22 # common / chelp / size, name(FILENAMESIZE), buf(MAXLINE) # # integer size # return size of entry from gethdr # character name # return name of entry from gethdr # character buf # buffer for reading help archive file define(INCL_CHELP,common/chelp/size,name(FILENAMESIZE),buf(MAXLINE) integer size; character name,buf) define(gethdr,phelp0) #-t- defns 344 ascii 15-Jan-84 15:04:22 #-h- gethdr 451 ascii 15-Jan-84 15:04:22 ## GetHdr -- Get next archive header from file. integer function gethdr( fd, buf, name, size) character buf(MAXLINE), c, name(FILENAMESIZE) integer ctoi, equal, getlin, getwrd # function(s) integer fd, i, len, size string hdr "#-h-" if( getlin( buf, fd) == EOF ) return(EOF) i = 1 len = getwrd( buf, i, name) if( equal( name, hdr) == NO ) return(ERR) len = getwrd( buf, i, name) size = ctoi( buf, i) call fold(name) return(YES) end #-t- gethdr 451 ascii 15-Jan-84 15:04:22 #-h- inihlp 586 ascii 15-Jan-84 15:04:23 ## IniHlp -- Initialize help system. integer function inihlp( file, ptrara, ptrsiz, fd) filedes fd integer i, ptrsiz, junk linepointer ptrara(ptrsiz) character file(FILENAMESIZE) integer gethdr, open, note # function(s) INCL_CHELP call close(fd) # close it if previously opened fd = open( file, READ) if( fd != ERR ) { for( i = 1 ; i < ptrsiz ; i = i + 1 ) { junk = note ( ptrara(i), fd ) if( gethdr( fd, buf, name, size) != YES ) break call fskip( fd, size) } call ptrcpy( NULLPOINTER, ptrara(i) ) return(OK) } else return(ERR) end #-t- inihlp 586 ascii 15-Jan-84 15:04:23 #-h- mrkhlp 770 ascii 15-Jan-84 15:04:23 ## MrkHlp -- Mark all header lines in help archive. integer function mrkhlp( fd, ptrara, key, outara) filedes fd integer j, i, junk, doall integer equal, gethdr, ptreq # function(s) linepointer ptrara(ARB), outara(ARB) character key(ARB) INCL_CHELP string summar "%" string all "?" if( equal( key, summar) == YES | equal( key, all) == YES ) doall = YES else doall = NO j = 1 for( i = 1 ; ptreq( ptrara(i), NULLPOINTER) == NO ; i = i + 1 ) { call seek( ptrara(i), fd) junk = gethdr( fd, buf, name, size) if( doall == YES | equal( name, key) == YES ) { call ptrcpy( ptrara(i), outara(j) ) j = j + 1 } if( j > 1 & doall == NO ) break } call ptrcpy( NULLPOINTER, outara(j) ) if( j > 1 ) return(OK) else return(ERR) end #-t- mrkhlp 770 ascii 15-Jan-84 15:04:23 #-h- puthlp 733 ascii 15-Jan-84 15:04:23 ## PutHlp -- Output help message. subroutine puthlp( fd, outara, key, out, putout) character key(ARB) filedes fd integer dosumm, i, junk, out integer equal, gethdr, getlin, ptreq # function(s) linepointer outara(ARB) external putout INCL_CHELP string summar "%" dosumm = equal( key, summar) for( i = 1 ; ptreq( outara(i), NULLPOINTER) == NO ; i = i + 1 ) { call seek( outara(i), fd) junk = gethdr( fd, buf, name, size) if( dosumm == YES ) { junk = getlin( buf, fd) call putout( buf, out) } else { size = size - getlin( buf, fd) for( junk = getlin( buf, fd) ; size > 0 ; junk = getlin( buf, fd) ) { call putout( buf, out) size = size - junk } } } return end #-t- puthlp 733 ascii 15-Jan-84 15:04:23 #-t- help.r 3554 ascii 15-Jan-84 15:23:20 #-h- hispmt.r 20718 ascii 15-Jan-84 15:23:21 #-h- defns 3203 ascii 15-Jan-84 15:04:57 ### Defns Symbol definitions for `logpmt'. define(GLOBAL,'g') define(CURLINE,'.') define(PREVLINE,'-') define(NEXTLINE,'+') define(LASTLINE,'$') define(SCAN,'/') define(BACKSCAN,'\') define(LINE0,1) define(PREV,0) define(NEXT,1) define(MAX_ED_LINES,25) # Maximum number of lines. define(BUFENT,5) # Words in buffer needed/line. # Now calculate size of buffer array = BUFENT * (MAX_ED_LINES + 2). # The 2 is to account for dummy lines before and after real lines. define(MAXBUF,arith(BUFENT,*,arith(MAX_ED_LINES,+,2))) define(SEEKADR,3) define(LINEID,4) define(SCREENSIZE,22) define(FORWARD,'+') define(BACKWARD,'-') define(LINE_NUMBER,0) define(LEFT_HAND_SIDE,1) # /clog00/ common block - formerly known as cbuf in the editor # put on a file called 'clog00' # Used only by logpmt # common /clog00/ buf(MAXBUF), lastbf # integer buf # Data structures describing each line. # integer lastbf # Last entry in buf used. define(I_CLOG00,common/clog00/buf(MAXBUF),lastbf integer buf,lastbf) # formerly known as clines # /clog01/ - common block for logpmt; holds line flags # put on a file called 'clog01' # Used only by logpmt # common /clog01/ line1, line2, nlines, curln, frstln, lastln, # number # integer line1 # first line number # integer line2 # second line number # integer nlines # number of line numbers specified # integer curln # current line: value of dot # integer frstln # first line of history # integer lastln # last line: value of $ # integer number # next available line number define(I_CLOG01,common/clog01/line1,line2,nlines,curln,frstln,lastln,number integer line1,line2,nlines,curln,frstln,lastln,number) # formerly known as cpat # /clog02/ - common block for logpmt # put on a file named 'clog02' # Used only by the logpmt # common /clog02/ pat(MAXPAT) # character pat # pattern define(I_CLOG02,common/clog02/pat(MAXPAT) character pat) # formerly known as cscrat # /clog03/ - common block for logpmt; holds scratch file info # put on a file called 'clog03' # Used only by the logpmt # common /clog03/ scr, scrend(2) , scrfil(FILENAMESIZE) # integer scr # scratch file id # integer scrend # end of info on scratch file # character scrfil # name of scratch file define(I_CLOG03,common/clog03/scr,scrend(2),scrfil(FILENAMESIZE) integer scr,scrend character scrfil) # formerly known as ctxt # /clog04/ - common block for logpmt # put on a file called 'clog04' # Used only by the logpmt # common /clog04/ txt(MAXLINE) # character txt # text line for matching and output define(I_CLOG04,common/clog04/txt(MAXLINE) character txt) # These definitions are used to avoid name collisions in `rlib'. define(pmtfcn,plog00) define(archiv,plog01) define(dohist,plog03) define(dolist,plog04) #define(edline,plog05) define(getb,plog06) define(getind,plog07) define(getlst,plog08) define(getnum,plog09) define(getone,plog10) define(getrhs,plog11) define(gettxt,plog12) define(gtfndx,plog13) define(inject,plog14) #define(logend,plog02) define(nextln,plog15) define(optpat,plog16) define(prevln,plog17) define(ptscan,plog18) define(relink,plog19) define(setb,plog20) define(setbuf,plog21) define(subst,plog22) #-t- defns 3203 ascii 15-Jan-84 15:04:57 #-h- logpmt 211 ascii 15-Jan-84 15:04:58 ### LogPmt prompt function with history integer function logpmt(pstr, buf, fd) character pstr(ARB), buf(ARB) filedes fd integer pmtfcn # function(s) external prompt return (pmtfcn (pstr, buf, fd, prompt)) end #-t- logpmt 211 ascii 15-Jan-84 15:04:58 #-h- ledpmt 234 ascii 15-Jan-84 15:04:59 ### LedPmt prompt function with history and intra-line editing integer function ledpmt(pstr, buf, fd) character pstr(ARB), buf(ARB) filedes fd integer pmtfcn # function(s) external lnedit return (pmtfcn (pstr, buf, fd, lnedit)) end #-t- ledpmt 234 ascii 15-Jan-84 15:04:59 #-h- pmtfcn 1721 ascii 15-Jan-84 15:04:59 ### PmtFcn Prompt function with history mechanism. ### pmtrtn is the function to be called to prompt for input ### status = pmtrtn(pstr, buf, fd) integer function pmtfcn( pstr, lin, int, pmtrtn) character c, lin(ARB), pstr(ARB) character clower # function(s) integer access, i, int, junk, k, nofile integer dohist, edline, equal, index, pmtrtn # function(s) external pmtrtn I_CLOG01 string null "" string whites " @t@n" data nofile / YES / if( nofile == YES ) { nofile = NO call setbuf } repeat { k = pmtrtn( pstr, lin, int) if( k == EOF ) call strcpy( null, lin) else if( lin(1) == '!' ) { c = clower( lin(2) ) if( c == 'h' | c == 'b' ) { for( i = 3 ; IS_LETTER( lin(i) ) ; i = i + 1 ) ; junk = dohist( lastln, lin, i) k = ERR } else if( c == 'w' ) { for( i = 3 ; lin(i) != EOS ; i = i + 1 ) if( index( whites, lin(i) ) > 0 ) break call skipbl( lin, i) access = WRITE if( lin(i) == '>' ) { i = i + 1 if( lin(i) == '>' ) { i = i + 1 access = APPEND } } call scopy( lin, i, lin, 1) i = index( lin, '@n') if( i > 0 ) lin(i) = EOS k = EOF } else if( c == 'q' ) { call strcpy( null, lin) k = EOF } else { k = edline(lin) call putlin( pstr, ERROUT) call putlin( lin, ERROUT) } } else if( lin(1) == ESCAPE & lin(2) == '!' ) { call scopy( lin, 2, lin, 1) k = k - 1 } } until( k != ERR ) if( k != EOF ) call archiv(lin) else { call logend( lin, access) nofile = YES # (dpm 13-Jun-81) } return(k) end #-t- pmtfcn 1721 ascii 15-Jan-84 15:04:59 #-h- archiv 209 ascii 15-Jan-84 15:04:59 ### LP_Archiv Archive lines. (LogPmt) subroutine archiv(lin) character lin(ARB) integer junk integer inject # function(s) if( lin(1) != '@n' ) # Don't log blank lins. junk = inject(lin) return end #-t- archiv 209 ascii 15-Jan-84 15:04:59 #-h- dohist 567 ascii 15-Jan-84 15:05:00 ### LP_DoHist Perform history display. (LogPmt) integer function dohist( line, lin, i) character direc, lin(ARB) integer curscr, i, lin1, lin2, line, screen integer ctoi, dolist # function(s) I_CLOG01 data screen, curscr / SCREENSIZE, SCREENSIZE / call skipbl( lin, i) if( lin(i) == '@n' ) screen = curscr else { screen = ctoi( lin, i) - 1 if( screen <= 0 ) screen = curscr else curscr = screen } lin1 = line - screen lin2 = line lin1 = max( frstln + 1, lin1) lin2 = min( lin2, lastln) dohist = dolist( lin1, lin2, lin(i) ) return end #-t- dohist 567 ascii 15-Jan-84 15:05:00 #-h- dolist 729 ascii 15-Jan-84 15:05:00 ### LP_DoList Print lines `from' through `to'. (LogPmt) integer function dolist( from, to, ch) integer gettxt # function(s) integer from, i, j, to, k, num, xpand character c, ch I_CLOG01 I_CLOG04 xpand = NO if( ch == 'l' | ch == 'L' ) xpand = YES for( i = from ; i <= to ; i = i + 1 ) { j = gettxt(i) call getb( j, LINEID, num) call putint( num, 3, STDOUT) # output line number call putch( ' ', STDOUT) for( k = 1 ; txt(k) != EOS ; k = k + 1 ) if( txt(k) >= ' ' | txt(k) == '@n' ) call putch( txt(k), STDOUT) else if( xpand == NO ) call putch( txt(k), STDOUT) else { call putch( '^', STDOUT) c = txt(k) + '@@' call putch( c, STDOUT) } } curln = to dolist = OK return end #-t- dolist 729 ascii 15-Jan-84 15:05:00 #-h- edline 969 ascii 15-Jan-84 15:05:01 ### LP_EdLine Perform line-editor command. (LogPmt) integer function edline(lin) character lin(ARB), sub(MAXPAT) integer final, gflag, i, junk, linsts, status integer getlst, getrhs, gettxt, length, optpat, subst # function(s) I_CLOG04 I_CLOG01 string badlin "# invalid lin number@n" string badpat "# invalid substitution@n" i = 2 status = OK if( getlst( lin, i, linsts) == OK ) if( line2 == frstln ) linsts = ERR else if( lin(i) == 's' | lin(i) == 'S' ) { status = ERR i = i + 1 if( optpat( lin, i, LEFT_HAND_SIDE ) == OK ) andif( getrhs( lin, i, sub, gflag) == OK ) { junk = gettxt(line2) # Fetch line. status = subst( txt, lin, sub, gflag) # Modify line. } } else { junk = gettxt(line2) call strcpy( txt, lin) } if( linsts == ERR ) { final = ERR call strcpy( badlin, lin) } else if( status == ERR ) { final = ERR call strcpy( badpat, lin) } else final = length(lin) curln = lastln return(final) end #-t- edline 969 ascii 15-Jan-84 15:05:01 #-h- getb 407 ascii 15-Jan-84 15:05:01 ### LP_GetB Get `value' of `type' in `buf(index)' (LogPmt) subroutine getb( index, type, value) integer index, type integer value(2) I_CLOG00 if( type == PREV ) value(1) = buf(index) else if( type == NEXT ) value(1) = buf( index + 1 ) else if( type == SEEKADR ) { value(1) = buf( index + 2 ) value(2) = buf( index + 3 ) } else if( type == LINEID ) value(1) = buf( index + 4 ) return end #-t- getb 407 ascii 15-Jan-84 15:05:01 #-h- getind 213 ascii 15-Jan-84 15:05:01 ### LP_GetInd Locate line index in buffer (LogPmt version) integer function getind(lin) integer lin, k, j I_CLOG01 k = LINE0 for( j = frstln ; j < lin ; j = j + 1 ) call getb( k, NEXT, k) return(k) end #-t- getind 213 ascii 15-Jan-84 15:05:01 #-h- getlst 584 ascii 15-Jan-84 15:05:02 ### LP_GetLst Collect line numbers at `lin(i)'; increment `i'. (LogPmt) integer function getlst( lin, i, status) character lin(MAXLINE) integer getone # function(s) integer i, num, status I_CLOG01 line2 = 0 for( nlines = 0 ; getone( lin, i, num, status) == OK ; ) { line1 = line2 line2 = num nlines = nlines + 1 if( lin(i) != ',' & lin(i) != ';' ) break if( lin(i) == ';' ) curln = num i = i + 1 } nlines = min( nlines, 2) if( nlines == 0 ) line2 = curln if( nlines <= 1 ) line1 = line2 if( status != ERR ) status = OK getlst = status return end #-t- getlst 584 ascii 15-Jan-84 15:05:02 #-h- getnum 952 ascii 15-Jan-84 15:05:02 ### LP_GetNum Convert one term to line number. (LogPmt) integer function getnum( lin, i, pnum, status) character lin(MAXLINE) integer ctoi, index, nextln, optpat, prevln, ptscan # function(s) integer i, pnum, status I_CLOG01 I_CLOG02 string digits "0123456789" getnum = OK if( index( digits, lin(i) ) > 0 ) { pnum = ctoi( lin, i) i = i - 1 # move back; to be advanced at the end } else if( lin(i) == CURLINE ) pnum = curln else if( lin(i) == LASTLINE ) pnum = lastln else if( lin(i) == PREVLINE ) pnum = prevln(curln) else if( lin(i) == NEXTLINE ) pnum = nextln(curln) else if( lin(i) == SCAN | lin(i) == BACKSCAN ) { if( optpat( lin, i, LINE_NUMBER ) == ERR ) # build the pattern getnum = ERR else if( lin(i) == SCAN ) getnum = ptscan( FORWARD, pnum) else getnum = ptscan( BACKWARD, pnum) } else getnum = EOF if( getnum == OK ) i = i + 1 # point at next character to be examined status = getnum return end #-t- getnum 952 ascii 15-Jan-84 15:05:02 #-h- getone 875 ascii 15-Jan-84 15:05:02 ### LP_GetOne Evaluate one line number expression. (LogPmt) integer function getone( lin, i, num, status) character lin(MAXLINE) integer getnum # function(s) integer i, istart, mul, num, pnum, status I_CLOG01 istart = i num = frstln call skipbl( lin, i) if( getnum( lin, i, num, status) == OK ) # first term repeat # + or - terms { call skipbl( lin, i) if( lin(i) != '+' & lin(i) != '-' ) { status = EOF break } if( lin(i) == '+' ) mul = +1 else mul = -1 i = i + 1 call skipbl( lin, i) if( getnum( lin, i, pnum, status) == OK ) num = num + mul * pnum if( status == EOF ) status = ERR } until( status != OK ) if( num < frstln | num > lastln ) status = ERR if( status == ERR ) getone = ERR else if( i <= istart ) getone = EOF else getone = OK status = getone return end #-t- getone 875 ascii 15-Jan-84 15:05:02 #-h- getrhs 675 ascii 15-Jan-84 15:05:03 ### LP_GetRhs Get substitution string for `s' command. (LogPmt) integer function getrhs( lin, i, sub, gflag) character lin(MAXLINE), sub(MAXPAT) integer index, length, maksub # function(s) integer gflag, i, j character clower # function(s) getrhs = ERR if( lin(i) == EOS ) return if( lin( i + 1 ) == EOS ) return if( index( lin( i + 1 ), lin(i) ) == 0 ) # insert missing delimiter { j = length(lin) call chcopy( lin(i), lin, j) call chcopy( '@n', lin, j) # add trailing '@n' } i = maksub( lin, i + 1, lin(i), sub) if( i == ERR ) return i = i + 1 if( clower( lin(i) ) == GLOBAL ) { i = i + 1 gflag = YES } else gflag = NO getrhs = OK return end #-t- getrhs 675 ascii 15-Jan-84 15:05:03 #-h- gettxt 442 ascii 15-Jan-84 15:05:03 ### LP_GetTxt Locate text for line, copy to `txt'. (LogPmt) integer function gettxt(lin) integer getind, getlin # function(s) integer lin, len, j, k, junk integer loc(2) I_CLOG00 I_CLOG03 I_CLOG04 I_CLOG01 string null "" if( lin > frstln & lin <= lastln ) { k = getind(lin) call getb( k, SEEKADR, loc) call seek( loc, scr) junk = getlin( txt, scr) } else { k = LINE0 call strcpy( null, txt) } gettxt = k return end #-t- gettxt 442 ascii 15-Jan-84 15:05:03 #-h- gtfndx 222 ascii 15-Jan-84 15:05:04 ### LP_GtFNdx Get index for next line. (LogPmt) integer function gtfndx(newind) I_CLOG00 if( lastbf + BUFENT < MAXBUF ) { newind = lastbf lastbf = lastbf + BUFENT } else newind = ERR gtfndx = newind return end #-t- gtfndx 222 ascii 15-Jan-84 15:05:04 #-h- inject 790 ascii 15-Jan-84 15:05:04 ### LP_Inject Insert `lin' after `curln'; write scratch. (LogPmt) integer function inject(lin) character lin(MAXLINE) integer gtfndx, note # function(s) integer k1, newind, junk I_CLOG01 I_CLOG03 if( gtfndx(newind) == ERR ) { call getb( LINE0, NEXT, newind) # Get index of frstln. call getb( newind, NEXT, k1) # Get index of second line. call relink( LINE0, k1, LINE0, k1) # Unlink frstln. frstln = frstln + 1 } call setb( newind, SEEKADR, scrend) call seek( scrend, scr) call putlin( lin, scr) junk = note ( scrend, scr) call setb( newind, LINEID, number) number = number + 1 call getb( LINE0, PREV, k1) # Get index of lastln. call relink( k1, newind, newind, LINE0) call relink( newind, LINE0, k1, newind) lastln = lastln + 1 curln = lastln inject = OK return end #-t- inject 790 ascii 15-Jan-84 15:05:04 #-h- nextln 171 ascii 15-Jan-84 15:05:04 ### LP_NextLn Get line after `lin'. (LogPmt) integer function nextln(lin) integer lin I_CLOG01 nextln = lin + 1 if( nextln > lastln ) nextln = frstln return end #-t- nextln 171 ascii 15-Jan-84 15:05:04 #-h- optpat 734 ascii 15-Jan-84 15:05:04 ### LP_OptPat Make pattern if specified at `lin(i)'. (LogPmt) integer function optpat( lin, i, type) character lin(MAXLINE) integer index, length, makpat # function(s) integer i, j, type I_CLOG02 if( lin(i) == EOS ) i = ERR else if( lin( i + 1 ) == EOS ) i = ERR else { if( type == LINE_NUMBER ) andif( index( lin( i + 1 ), lin(i) ) == 0 ) # Add missing delimiter. { j = length(lin) # Location of '@n'. call chcopy( lin(i), lin, j) # Add delimiter. call chcopy( '@n', lin, j) } if( lin( i + 1 ) == lin(i) ) i = i + 1 else i = makpat( lin, i + 1, lin(i), pat) } if( pat(1) == EOS ) i = ERR if( i == ERR ) { pat(1) = EOS optpat = ERR } else optpat = OK return end #-t- optpat 734 ascii 15-Jan-84 15:05:04 #-h- prevln 172 ascii 15-Jan-84 15:05:05 ### LP_PrevLn Get line before `lin'. (LogPmt) integer function prevln(lin) integer lin I_CLOG01 prevln = lin - 1 if( prevln < frstln ) prevln = lastln return end #-t- prevln 172 ascii 15-Jan-84 15:05:05 #-h- ptscan 405 ascii 15-Jan-84 15:05:05 ### LP_PtScan Scan for next occurrence of pattern. (LogPmt) integer function ptscan( way, num) integer k, num, way integer gettxt, match, nextln, prevln # function(s) I_CLOG01 I_CLOG02 I_CLOG04 num = curln repeat { if( way == FORWARD ) num = nextln(num) else num = prevln(num) k = gettxt(num) if( match( txt, pat) == YES ) return(OK) } until( num == curln ) return(ERR) end #-t- ptscan 405 ascii 15-Jan-84 15:05:05 #-h- relink 164 ascii 15-Jan-84 15:05:06 ### LP_Relink Rewrite two half line links. (LogPmt) subroutine relink( a, x, y, b) integer a, b, x, y call setb( x, PREV, a) call setb( y, NEXT, b) return end #-t- relink 164 ascii 15-Jan-84 15:05:06 #-h- setb 408 ascii 15-Jan-84 15:05:06 ### LP_SetB Set `type' in `buf(index)' to `value'. (Logpmt) subroutine setb( index, type, value) integer index, type integer value(2) I_CLOG00 if( type == PREV ) buf(index) = value(1) else if( type == NEXT ) buf( index + 1 ) = value(1) else if( type == SEEKADR ) { buf( index + 2 ) = value(1) buf( index + 3 ) = value(2) } else if( type == LINEID ) buf( index + 4 ) = value(1) return end #-t- setb 408 ascii 15-Jan-84 15:05:06 #-h- setbuf 607 ascii 15-Jan-84 15:05:06 ### LP_SetBuf Create scratch file, set up line 0. (LogPmt) subroutine setbuf filedes create # function(s) integer gtfndx, note # function(s) integer junk, k I_CLOG00 I_CLOG01 I_CLOG03 string fil "log" call scratf( fil, scrfil) # Get unique name for scratch file. scr = create( scrfil, READWRITE) if( scr == ERR ) call cant(scrfil) junk = note ( scrend, scr) lastbf = LINE0 junk = gtfndx(k) # Get index of line 0. call relink( k, k, k, k) # Establish initial linked list. frstln = 0 # Initialize first line. curln = 0 lastln = 0 number = 1 # Next available line number. return end #-t- setbuf 607 ascii 15-Jan-84 15:05:06 #-h- subst 836 ascii 15-Jan-84 15:05:06 ### LP_Subst Substitute `sub' for occurrences of pattern. (LogPmt) integer function subst( old, new, sub, gflag) character new(MAXLINE), old(MAXLINE), sub(MAXPAT) integer addset, amatch # function(s) integer gflag, j, junk, k, lastm, m, subbed I_CLOG01 I_CLOG02 j = 1 subbed = NO lastm = 0 for( k = 1 ; old(k) != EOS ; ) { if( gflag == YES | subbed == NO ) m = amatch( old, k, pat) else m = 0 if( m > 0 & lastm != m ) # replace matched text { subbed = YES call catsub( old, k, m, sub, new, j, MAXLINE) lastm = m } if( m == 0 | m == k ) # no match or null match { junk = addset( old(k), new, j, MAXLINE) k = k + 1 } else # skip matched text k = m } if( addset( EOS, new, j, MAXLINE) == NO ) subst = ERR else if( subbed == NO ) subst = ERR else subst = OK return end #-t- subst 836 ascii 15-Jan-84 15:05:06 #-h- logend 734 ascii 15-Jan-84 15:05:07 ### LP_ClrBuf CLear buffer and gun scratch file. (LogPmt) subroutine logend( fil, access) character c, fil(FILENAMESIZE) character getch # function(s) filedes create, open # function(s) integer access, out, junk integer remove # function(s) I_CLOG03 call close(scr) if( fil(1) != EOS ) # User wants file saved. { scr = open( scrfil, READ) # Reopen scrfil at beginning. if( scr != ERR ) # Better not be any errors. { out = create( fil, access) # Open user's file at desired access. if( out != ERR ) # Hope there's no error. { while( getch( c, scr) != EOF ) # Copy the log file. call putch( c, out) call close(out) } call close(scr) } } junk = remove(scrfil) return end #-t- logend 734 ascii 15-Jan-84 15:05:07 #-t- hispmt.r 20718 ascii 15-Jan-84 15:23:21 #-h- imsort.r 4858 ascii 15-Jan-84 15:23:25 #-h- imsym 295 ascii 15-Jan-84 15:05:41 define(LAST_PUT,0) # offset into Mem for last put pointer define(LAST_GET,1) # " " " " " get " define(LAST_PTR,2) # offset into Mem for last pointer define(START_DATA,3) # offset into Mem for start of pointer array define(LOGPTR,20) # log base 2 of number of entries to sort #-t- imsym 295 ascii 15-Jan-84 15:05:41 #-h- iminit 494 ascii 15-Jan-84 15:05:41 ## IMInit -- Initialize in-memory sorting array. pointer function iminit( memsiz, avetok) integer memsiz, avetok DS_DECL( Mem, 1) integer ptrsiz pointer table pointer dsget call dsinit(memsiz) ptrsiz = START_DATA + ( memsiz / ( 1 + avetok / CHAR_PER_INT ) ) table = dsget(ptrsiz) if( table != LAMBDA ) { Mem( table + LAST_PUT ) = table + START_DATA - 1 Mem( table + LAST_GET ) = table + START_DATA - 1 Mem( table + LAST_PTR ) = table + ptrsiz - 1 } return(table) end #-t- iminit 494 ascii 15-Jan-84 15:05:41 #-h- imget 360 ascii 15-Jan-84 15:05:41 ## IMGet -- Get next token from in-memory sort area integer function imget( table, buf) pointer table character buf(ARB) DS_DECL( Mem, 1) integer i if( Mem( table + LAST_GET ) < Mem( table + LAST_PUT ) ) { i = Mem( table + LAST_GET ) + 1 Mem( table + LAST_GET ) = i call scopy( cMem, Mem(i), buf, 1) return(OK) } else return(EOF) end #-t- imget 360 ascii 15-Jan-84 15:05:41 #-h- imsort 1027 ascii 15-Jan-84 15:05:41 ## IMSort -- Quicksort for character lines. subroutine imsort(table) pointer table DS_DECL( Mem, 1) integer imcomp integer i, j, lv(LOGPTR), p, pivlin, uv(LOGPTR) lv(1) = table + START_DATA uv(1) = Mem( table + LAST_PUT ) p = 1 while( p > 0 ) if( lv(p) >= uv(p) ) # only one element in this subset p = p - 1 # pop stack else { i = lv(p) - 1 j = uv(p) pivlin = Mem(j) # pivot line while( i < j ) { for( i = i + 1 ; imcomp( Mem(i), pivlin, cMem) < 0 ; i = i + 1 ) ; for( j = j - 1 ; j > i ; j = j - 1 ) if( imcomp( Mem(j), pivlin, cMem) <= 0 ) break if( i < j ) # out of order pair call imexch( Mem(i), Mem(j), cMem) } j = uv(p) # move pivot to position i call imexch( Mem(i), Mem(j), cMem) if( i - lv(p) < uv(p) - i ) # stack so shorter done first { lv( p + 1 ) = lv(p) uv( p + 1 ) = i - 1 lv(p) = i + 1 } else { lv( p + 1 ) = i + 1 uv( p + 1 ) = uv(p) uv(p) = i - 1 } p = p + 1 # push onto stack } return end #-t- imsort 1027 ascii 15-Jan-84 15:05:41 #-h- imput 447 ascii 15-Jan-84 15:05:42 ## IMPut -- Put a token into the in-memory sort area. integer function imput( table, buf) pointer table character buf(ARB) DS_DECL( Mem, 1) pointer text pointer sdupl integer i imput = ERR if( Mem( table + LAST_PUT ) < Mem( table + LAST_PTR ) ) { text = sdupl(buf) if( text != LAMBDA ) { i = Mem( table + LAST_PUT ) + 1 Mem( table + LAST_PUT ) = i Mem(i) = cvt_to_cptr(text) imput = OK } } return end #-t- imput 447 ascii 15-Jan-84 15:05:42 #-h- imexch 175 ascii 15-Jan-84 15:05:42 ## IMExch -- Exchange linbuf(lp1) with linbuf(lp2) . subroutine imexch( lp1, lp2, linbuf) character linbuf(ARB) integer k, lp1, lp2 k = lp1 lp1 = lp2 lp2 = k return end #-t- imexch 175 ascii 15-Jan-84 15:05:42 #-h- imcomp 320 ascii 15-Jan-84 15:05:42 ## IMComp -- Compare two strings in in-memory sort area. integer function imcomp( i, j, lin) integer i, j, k, l character lin(ARB) k = i l = j while( lin(k) == lin(l) ) { if( lin(k) == EOS ) return(0) # strings are equal k = k + 1 l = l + 1 } if( lin(k) < lin(l) ) return(-1) else return(1) end #-t- imcomp 320 ascii 15-Jan-84 15:05:42 #-h- imuniq 417 ascii 15-Jan-84 15:05:42 subroutine imuniq(table) pointer table DS_DECL(Mem, 1) integer imcomp integer last, out, cur, next last = Mem(table + LAST_PUT) out = table + START_DATA for (cur = table + START_DATA; cur <= last; cur = next) { for (next = cur + 1; next <= last; next = next + 1) if (imcomp(Mem(cur), Mem(next), cMem) != 0) break Mem(out) = Mem(cur) out = out + 1 } Mem(table + LAST_PUT) = out - 1 return end #-t- imuniq 417 ascii 15-Jan-84 15:05:42 #-h- imrset 117 ascii 15-Jan-84 15:05:43 subroutine imrset(table) pointer table DS_DECL(Mem,1) Mem (table + LAST_GET) = table + START_DATA - 1 return end #-t- imrset 117 ascii 15-Jan-84 15:05:43 #-t- imsort.r 4858 ascii 15-Jan-84 15:23:25 #-h- misc.r 26742 ascii 15-Jan-84 15:23:27 #-h- acopy 280 ascii 15-Jan-84 15:07:01 ## ACopy -- Copy `size' characters from `ifd' to `ofd'. subroutine acopy( ifd, ofd, size) character getch # function(s) character c filedes ifd, ofd integer i, size for( i = 1 ; i <= size ; i = i + 1 ) { if( getch( c, ifd) != EOF ) call putch( c, ofd) } return end #-t- acopy 280 ascii 15-Jan-84 15:07:01 #-h- addset 241 ascii 15-Jan-84 15:07:01 ## AddSet -- Put `c' in `string(j)' if it fits; increment `j'. integer function addset( c, str, j, maxsiz) integer j, maxsiz character c, str(maxsiz) if( j > maxsiz ) return(NO) else { str(j) = c j = j + 1 return(YES) } end #-t- addset 241 ascii 15-Jan-84 15:07:01 #-h- addstr 226 ascii 15-Jan-84 15:07:01 integer function addstr(s, str, j, maxsiz) character s(ARB), str(ARB) integer j, maxsiz, i integer length if ((length(s) + j) > maxsiz) return(NO) for (i=1; s(i) != EOS; i=i+1) call chcopy(s(i), str, j) return(YES) end #-t- addstr 226 ascii 15-Jan-84 15:07:01 #-h- adrfil 222 ascii 15-Jan-84 15:07:02 ## AdrFil -- Get name of software tools user-info database. subroutine adrfil(file) character file(FILENAMESIZE) string addr "address" call getdir( MSGDIRECTORY, LOCAL, file) call concat( file, addr, file) return end #-t- adrfil 222 ascii 15-Jan-84 15:07:02 #-h- alldig 412 ascii 15-Jan-84 15:07:02 # alldig - return YES if str is all digits integer function alldig (str) character str (ARB) ifnotdef(IS_DIGIT) character type enddef integer i alldig = NO if (str (1) == EOS) return for (i = 1; str (i) != EOS; i = i + 1) ifdef(IS_DIGIT) if (!IS_DIGIT(str (i))) return elsedef if (type(str(i)) != DIGIT) return enddef alldig = YES return end #-t- alldig 412 ascii 15-Jan-84 15:07:02 #-h- badarg 247 ascii 15-Jan-84 15:07:02 ## BadArg -- Output `invalid argument' message. subroutine badarg(arg) character arg(ARB) string msg1 "? Ignoring invalid argument `" string msg2 "'@n" call putlin( msg1, ERROUT) call putlin( arg, ERROUT) call putlin( msg2, ERROUT) return end #-t- badarg 247 ascii 15-Jan-84 15:07:02 #-h- bubble 307 ascii 15-Jan-84 15:07:03 ## Bubble -- bubble sort v(1)...v(n) increasing. subroutine bubble( v, n) integer i, j, k, n, v(ARB) for( i = n ; i > 1 ; i = i - 1 ) for( j = 1 ; j < i ; j = j + 1 ) if( v(j) > v( j + 1 ) ) # compare { k = v(j) # exchange v(j) = v( j + 1 ) v( j + 1 ) = k } return end #-t- bubble 307 ascii 15-Jan-84 15:07:03 #-h- cant 313 ascii 15-Jan-84 15:07:03 ## Can't -- Display the bad news that `file' can't be opened; then exit subroutine cant(file) character file(ARB) string msg1 "? Can't open file named `" string msg2 "'@n" call putlin( msg1, ERROUT) call putlin( file, ERROUT) call putlin( msg2, ERROUT) call endst(ERR) # Indicate error to parent process. end #-t- cant 313 ascii 15-Jan-84 15:07:03 #-h- chcopy 128 ascii 15-Jan-84 15:07:03 # subroutine chcopy(c, buf, i) # # character c, buf(ARB) # integer i # # buf(i) = c # i = i + 1 # buf(i) = EOS # # return # end #-t- chcopy 128 ascii 15-Jan-84 15:07:03 #-h- clower 367 ascii 15-Jan-84 15:07:04 # ## clower - change letter to lower case # character function clower(c) # # character c, k # # if (c >= 'A' & c <= 'Z') # { #avoid integer overflow in byte machines # k = 'a' - 'A' # clower = c + k # } # else # clower = c # # return # end #-t- clower 367 ascii 15-Jan-84 15:07:04 #-h- concat 191 ascii 15-Jan-84 15:07:04 # subroutine concat(first, second, out) # # character first(ARB), second(ARB), out(ARB) # integer i # # i = 1 # call stcopy(first, 1, out, i) # call scopy(second, 1, out, i) # # return # end #-t- concat 191 ascii 15-Jan-84 15:07:04 #-h- ctoc 263 ascii 15-Jan-84 15:07:04 ### CToC Convert EOS-terminated string to EOS-terminated string integer function ctoc(from, to, len) integer len character from(ARB), to(len) integer i for( i = 1 ; i < len & from(i) != EOS ; i = i + 1 ) to(i) = from(i) to(i) = EOS return( i - 1 ) end #-t- ctoc 263 ascii 15-Jan-84 15:07:04 #-h- ctodi 486 ascii 15-Jan-84 15:07:05 ## CToDI -- Convert character string to pair of integers. subroutine ctodi( buf, i, di) character buf(ARB), hi(10), lo(6), temp(MAXCHARS) integer di(2), i, j, len integer ctoi, getwrd # function(s) len = getwrd( buf, i, temp) if( len <= 4 ) { hi(1) = EOS call strcpy( temp, lo) } else { len = len - 4 for( j = 1 ; j <= len ; j = j + 1 ) hi(j) = temp(j) hi(j) = EOS call scopy( temp, j, lo, 1) } j = 1 di(1) = ctoi( hi, j) j = 1 di(2) = ctoi( lo, j) return end #-t- ctodi 486 ascii 15-Jan-84 15:07:05 #-h- ctoi 470 ascii 15-Jan-84 15:07:05 ## CToI -- Convert string at `in(i)' to integer; increment `i'. integer function ctoi( in, i) character in(ARB) integer index # function(s) integer d, i, sign string digits "0123456789" while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 sign = 1 if( in(i) == '-' ) { sign = -1 i = i + 1 } for( ctoi = 0 ; in(i) != EOS ; i = i + 1 ) { d = index( digits, in(i) ) if( d == 0 ) # non-digit break ctoi = 10 * ctoi + d - 1 } return( sign * ctoi ) end #-t- ctoi 470 ascii 15-Jan-84 15:07:05 #-h- cupper 370 ascii 15-Jan-84 15:07:06 # ## cupper - change letter to upper case # character function cupper(c) # # character c, k # # if (c >= 'a' & c <= 'z') # { #avoid overflow with byte-oriented machines # k = 'A' - 'a' # cupper = c + k # } # else # cupper = c # # return # end #-t- cupper 370 ascii 15-Jan-84 15:07:06 #-h- disize 379 ascii 15-Jan-84 15:07:06 ## DiSize -- determine size of `file' in characters as a double integer integer function disize(file, di) character getch # function(s) character c, file(ARB) integer open # function(s) integer di(2) filedes fd initdi(di) fd = open( file, READ) if( fd == ERR ) return(ERR) else { while (getch( c, fd) != EOF ) incrdi(di) call close(fd) } return(OK) end #-t- disize 379 ascii 15-Jan-84 15:07:06 #-h- ditoc 515 ascii 15-Jan-84 15:07:06 ## DIToC -- Convert a pair of integers to a character string. integer function ditoc( di, buf, size) integer di(2), i, j, n, size integer itoc # function(s) character buf(size), lo(5), temp(MAXCHARS) n = itoc( di(2), lo, 5) if( di(1) > 0 ) { i = itoc( di(1), temp, MAXCHARS) + 1 for( j = n + 1 ; j <= 4 ; j = j + 1 ) call chcopy( '0', temp, i) } else temp(1) = EOS call concat( temp, lo, temp) n = length(temp) + 1 - size i = max( n, 1) call scopy( temp, i, buf, 1) return( length(buf) ) end #-t- ditoc 515 ascii 15-Jan-84 15:07:06 #-h- equal 340 ascii 15-Jan-84 15:07:07 # ## equal - compare str1 to str2; return YES if equal, NO if not # integer function equal (str1, str2) # character str1(ARB), str2(ARB) # integer i # # for (i=1; str1(i) == str2(i); i=i+1) # if (str1(i) == EOS) # { # equal = YES # return # } # equal = NO # return # end #-t- equal 340 ascii 15-Jan-84 15:07:07 #-h- error 136 ascii 15-Jan-84 15:07:07 ## Error -- Print message and terminate execution. subroutine error (line) character line(ARB) call remark (line) call endst(ERR) end #-t- error 136 ascii 15-Jan-84 15:07:07 #-h- exppth 326 ascii 15-Jan-84 15:07:07 ## ExpPth -- Pointers in `ptr' to fields of `path'. subroutine exppth( path, depth, ptr, buf) character buf(ARB), path(ARB) integer depth, i, ptr(MAXDIRECTS) integer gtftok # function(s) depth = 0 i = 1 repeat { depth = depth + 1 ptr(depth) = i } until( gtftok( path, i, buf) == 0 ) depth = depth - 1 return end #-t- exppth 326 ascii 15-Jan-84 15:07:07 #-h- fcopy 196 ascii 15-Jan-84 15:07:08 ## FCopy -- Copy file `in' to file `out'. subroutine fcopy( in, out) character c character getch # function(s) filedes in, out while( getch( c, in) != EOF ) call putch( c, out) return end #-t- fcopy 196 ascii 15-Jan-84 15:07:08 #-h- fmtdat 1500 ascii 15-Jan-84 15:07:08 ## FmtDat -- Format date and time information. subroutine fmtdat( date, time, now, form) character date(10), time(9), temp(3) integer now(7), form integer i, j, k integer itoc # function(s) string months "JanFebMarAprMayJunJulAugSepOctNovDec" # if form == DIGIT, return mm/dd/yy in date # if form == LETTER, return dd-Mmm-yy in date # return hh:mm:ss in time k = 1 if( form == DIGIT ) { if( itoc( now(2), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '/', date, k) if( itoc( now(3), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '/', date, k) if( itoc( mod( now(1), 100), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) } else { if( itoc( now(3), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) call chcopy( '-', date, k) for( j = 3 * ( now(2) - 1 ) + 1 ; k <= 6 ; j = j + 1 ) call chcopy( months(j), date, k) call chcopy( '-', date, k) if( itoc( mod( now(1), 100), temp, 3) == 1 ) call chcopy( '0', date, k) call stcopy( temp, 1, date, k) } k = 1 if( itoc( now(4), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) call chcopy( ':', time, k) if( itoc( now(5), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) call chcopy( ':', time, k) if( itoc( now(6), temp, 3) == 1 ) call chcopy( '0', time, k) call stcopy( temp, 1, time, k) return end #-t- fmtdat 1500 ascii 15-Jan-84 15:07:08 #-h- fold 203 ascii 15-Jan-84 15:07:08 # ## fold - fold all letters to lower case # subroutine fold (token) # character token(ARB), clower # integer i # # for (i=1; token(i) != EOS; i=i+1) # token(i) = clower(token(i)) # return # end #-t- fold 203 ascii 15-Jan-84 15:07:08 #-h- fsize 344 ascii 15-Jan-84 15:07:09 ## FSize -- Determine size of `file' in characters. integer function fsize(file) character getch # function(s) character c, file(ARB) integer open # function(s) filedes fd fd = open( file, READ) if( fd == ERR ) fsize = ERR else { for( fsize = 0 ; getch( c, fd) != EOF ; fsize = fsize + 1 ) ; call close(fd) } return end #-t- fsize 344 ascii 15-Jan-84 15:07:09 #-h- fskip 231 ascii 15-Jan-84 15:07:09 ## FSkip -- Skip `n' characters on file `fd'. subroutine fskip( fd, n) character getch # function(s) character c filedes fd integer i, n for( i = 1 ; i <= n ; i = i + 1 ) if( getch( c, fd) == EOF ) break return end #-t- fskip 231 ascii 15-Jan-84 15:07:09 #-h- getc 142 ascii 15-Jan-84 15:07:09 # ## getc - get character from STDIN # character function getc(c) # # character c # character getch # # getc = getch(c, STDIN) # return # end #-t- getc 142 ascii 15-Jan-84 15:07:09 #-h- getwrd 367 ascii 15-Jan-84 15:07:10 ## GetWrd -- Get non-blank word from `in(i)' into `out'; increment `i'. integer function getwrd( in, i, out) character in(ARB), out(ARB) integer i, j while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 j = 1 while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' ) { out(j) = in(i) i = i + 1 j = j + 1 } out(j) = EOS getwrd = j - 1 return end #-t- getwrd 367 ascii 15-Jan-84 15:07:10 #-h- gitocf 940 ascii 15-Jan-84 15:07:10 integer function gitocf(int, str, size, base, width, fc) integer mod integer int, size, base, width character str(size), fc integer intval, b, i, d, j character k string digits "0123456789abcdefghijklmnopqrstuvwxyz" intval = abs(int) b = base if (b < 2 | b > 36) b = 10 str(1) = EOS i = 1 repeat { # generate digits i = i + 1 d = mod(intval, b) + 1 str(i) = digits(d) intval = intval / b } until (intval == 0 | i >= size) if (int < 0 & i < size) { # then sign i = i + 1 str(i) = '-' } while (i <= width) if (i >= size) break else { i = i + 1 str(i) = fc } gitocf = i - 1 for (j = 1; j < i; j = j + 1) { # then reverse k = str(i) str(i) = str(j) str(j) = k i = i - 1 } return end #-t- gitocf 940 ascii 15-Jan-84 15:07:10 #-h- gtftok 329 ascii 15-Jan-84 15:07:10 # integer function gtftok(buf, i, token) # # character buf(ARB), token(ARB) # integer i, j # # if (buf(i) == '/') # i = i + 1 # j = 1 # while (buf(i) != '/' & buf(i) != EOS) # { # token(j) = buf(i) # i = i + 1 # j = j + 1 # if (buf(i-1) == '\') # break # } # token(j) = EOS # gtftok = j - 1 # # return # end #-t- gtftok 329 ascii 15-Jan-84 15:07:10 #-h- impath 536 ascii 15-Jan-84 15:07:11 ### impath - generate search path for standard images to be spawned #subroutine impath(path) # #character path(ARB) #integer i, j, n #integer length # #string spath "~usr/@e~bin/@e@n" # usr:bin # #call tooldr(path, PATH) # get ~/tools/ #n = length(path) + 2 # move string up one location #for (j=n, i=n-1; i > 0; i=i-1, j=j-1) # path(j) = path(i) #path(1) = EOS # search current directory first #for (i=1, j=n+1; spath(i) != '@n'; i=i+1, j=j+1) # path(j) = spath(i) #call chcopy('@n', path, j) # terminate path # #return #end #-t- impath 536 ascii 15-Jan-84 15:07:11 #-h- index 255 ascii 15-Jan-84 15:07:11 # ## index - find character c in string str # integer function index(str, c) # character c, str(ARB) # # for (index = 1; str(index) != EOS; index = index + 1) # if (str(index) == c) # return # index = 0 # return # end #-t- index 255 ascii 15-Jan-84 15:07:11 #-h- indexs 428 ascii 15-Jan-84 15:07:12 ## IndexS -- Return index of `sub' in `str'. integer function indexs( str, sub) character str(ARB), sub(ARB) integer i, j, k for( i = 1 ; str(i) != EOS ; i = i + 1 ) { j = i for( k = 1 ; ; k = k + 1 ) { if( sub(k) == EOS ) # found it. return(i) else if( str(j) == EOS ) # ran out of string. return(0) else if( str(j) != sub(k) ) # try next posn. break j = j + 1 } } return(0) end #-t- indexs 428 ascii 15-Jan-84 15:07:12 #-h- itoc 613 ascii 15-Jan-84 15:07:12 ## IToC -- Convert integer `int' to character string in `str'. integer function itoc( int, str, size) integer mod # function(s) integer d, i, int, intval, j, k, size character str(size) string digits "0123456789" intval = abs(int) str(1) = EOS i = 1 repeat # generate digits { i = i + 1 d = mod( intval, 10) str(i) = digits( d + 1 ) intval = intval / 10 } until( intval == 0 | i >= size ) if( int < 0 & i < size ) # then sign { i = i + 1 str(i) = '-' } itoc = i - 1 for( j = 1 ; j < i ; j = j + 1 ) # then reverse { k = str(i) str(i) = str(j) str(j) = k i = i - 1 } return end #-t- itoc 613 ascii 15-Jan-84 15:07:12 #-h- length 184 ascii 15-Jan-84 15:07:13 # ## length - compute length of string # integer function length (str) # # character str(ARB) # # for (length=0; str(length+1) != EOS; length = length + 1) # ; # return # end #-t- length 184 ascii 15-Jan-84 15:07:13 #-h- putc 118 ascii 15-Jan-84 15:07:13 # ## putc - put character onto STDOUT # subroutine putc (c) # # character c # # call putch (c, STDOUT) # return # end #-t- putc 118 ascii 15-Jan-84 15:07:13 #-h- putdec 387 ascii 15-Jan-84 15:07:13 # ## putdec - put decimal integer n in field width >= w # subroutine putdec(n,w) # character chars(MAXCHARS) # integer itoc # integer i,n,nd,w # # nd = itoc(n,chars,MAXCHARS) # for(i = nd+1; i <= w; i = i+1) # call putc(' ') # for(i = 1; i <= nd; i = i+1) # call putc(chars(i)) # return # end #-t- putdec 387 ascii 15-Jan-84 15:07:13 #-h- putint 264 ascii 15-Jan-84 15:07:14 ## PutInt -- Output integer `n' on `fd' in field `w' characters wide. subroutine putint( n, w, fd) character chars(MAXCHARS) filedes fd integer itoc # function(s) integer junk, n, w junk = itoc( n, chars, MAXCHARS) call putstr( chars, w, fd) return end #-t- putint 264 ascii 15-Jan-84 15:07:14 #-h- putlnl 277 ascii 15-Jan-84 15:07:14 ## putlnl - putlin, then flush, if necessary subroutine putlnl(buf, int) character buf(ARB) integer int, i for (i=1; buf(i) != EOS; i=i+1) call putch(buf(i), int) if (i > 1) { if (buf(i-1) != '@n') call putch('@n', int) } else call putch('@n', int) return end #-t- putlnl 277 ascii 15-Jan-84 15:07:14 #-h- putptr 276 ascii 15-Jan-84 15:07:14 ## PutPtr -- Output pointer `ptr' as a character string on `fd'. subroutine putptr( ptr, fd) linepointer ptr filedes fd integer junk integer ptrtoc # function(s) character temp(LINEPTRSIZE) junk = ptrtoc( ptr, temp, LINEPTRSIZE) call putlin( temp, fd) return end #-t- putptr 276 ascii 15-Jan-84 15:07:14 #-h- putstr 397 ascii 15-Jan-84 15:07:15 ## PutStr -- Output `str' on `fd' in field `w' characters wide. subroutine putstr( str, w, fd) character str(ARB) filedes fd integer length # function(s) integer w len = length(str) for( i = len + 1 ; i <= w ; i = i + 1 ) call putch( ' ', fd) for( i = 1 ; i <= len ; i = i + 1 ) call putch( str(i), fd) for( i = ( -w ) - len ; i > 0 ; i = i - 1 ) call putch( ' ', fd) return end #-t- putstr 397 ascii 15-Jan-84 15:07:15 #-h- query 287 ascii 15-Jan-84 15:07:15 ## Query -- Print usage message, if requested. subroutine query(msg) character msg(ARB) integer getarg # function(s) character arg1(3), arg2(1) if( getarg( 1, arg1, 3) != EOF & getarg( 2, arg2, 1) == EOF ) if( arg1(1) == '?' & arg1(2) == EOS ) call error(msg) return end #-t- query 287 ascii 15-Jan-84 15:07:15 #-h- scopy 303 ascii 15-Jan-84 15:07:16 # ## scopy - copy string at from(i) to to(j) # subroutine scopy(from, i, to, j) # character from(ARB), to(ARB) # integer i, j, k1, k2 # # k2 = j # for (k1 = i; from(k1) != EOS; k1 = k1 + 1) { # to(k2) = from(k1) # k2 = k2 + 1 # } # to(k2) = EOS # return # end #-t- scopy 303 ascii 15-Jan-84 15:07:16 #-h- sdrop 355 ascii 15-Jan-84 15:07:16 ### SDrop Drop characters from a string APL-style integer function sdrop( from, to, chars) character from(ARB), to(ARB) integer chars integer len, start integer ctoc, length, min len = length(from) if( chars < 0 ) return( ctoc( from, to, len + chars + 1)) else { start = min( chars, len) return( ctoc( from( start + 1), to, len + 1 )) } end #-t- sdrop 355 ascii 15-Jan-84 15:07:16 #-h- shell 398 ascii 15-Jan-84 15:07:17 ## Shell -- Shell sort v(1)...v(n) increasing. subroutine shell( v, n) integer gap, i, j, jg, k, n, v(ARB) for( gap = n / 2 ; gap > 0 ; gap = gap / 2 ) for( i = gap + 1 ; i <= n ; i = i + 1 ) for( j = i - gap ; j > 0 ; j = j - gap ) { jg = j + gap if( v(j) <= v(jg) ) # compare break k = v(j) # exchange v(j) = v(jg) v(jg) = k } return end #-t- shell 398 ascii 15-Jan-84 15:07:17 #-h- skipbl 171 ascii 15-Jan-84 15:07:17 ## SkipBl -- Skip blanks and tabs at `lin(i)'. subroutine skipbl( lin, i) character lin(ARB) integer i while( lin(i) == ' ' | lin(i) == '@t' ) i = i + 1 return end #-t- skipbl 171 ascii 15-Jan-84 15:07:17 #-h- stake 352 ascii 15-Jan-84 15:07:17 ### STake take characters from a string APL-style integer function stake( from, to, chars) character from(ARB), to(ARB) integer chars integer len, start integer ctoc, length, max len = length(from) if( chars < 0 ) { start = max( len + chars, 0) return( ctoc( from( start + 1), to, len + 1)) } else return( ctoc( from, to, chars + 1)) end #-t- stake 352 ascii 15-Jan-84 15:07:17 #-h- stcopy 262 ascii 15-Jan-84 15:07:18 ### stcopy - copy string at from(i) to to(j); increment j # subroutine stcopy(from, i, to, j) # character from(ARB), to(ARB) # integer i, j, k # # for (k=i; from(k) != EOS; k=k+1) # { # to(j) = from(k) # j = j + 1 # } # to(j) = EOS # # return # end #-t- stcopy 262 ascii 15-Jan-84 15:07:18 #-h- strcmp 488 ascii 15-Jan-84 15:07:18 # ## strcmp - compare 2 strings # # integer function strcmp (str1, str2) # character str1(ARB), str2(ARB) # integer i # # for (i=1; str1(i) == str2(i); i=i+1) # { # if (str1(i) == EOS) # { # strcmp = 0 # return # } # } # if (str1(i) == EOS) # strcmp = -1 # else if (str2(i) == EOS) # strcmp = + 1 # else if (str1(i) < str2(i)) # strcmp = -1 # else # strcmp = +1 # return # end #-t- strcmp 488 ascii 15-Jan-84 15:07:18 #-h- strcpy 181 ascii 15-Jan-84 15:07:19 # subroutine strcpy(in, out) # # character in(ARB), out(ARB) # integer i # # i = 0 # repeat # { # i = i + 1 # out(i) = in(i) # } # until (in(i) == EOS) # # return # end #-t- strcpy 181 ascii 15-Jan-84 15:07:19 #-h- strim 257 ascii 15-Jan-84 15:07:19 ### STrim trim trailing blanks and tabs from a string integer function strim(str) character str(ARB) integer i, lnb lnb = 0 for( i = 1 ; str(i) != EOS ; i = i + 1 ) if( str(i) != ' ' & str(i) != '@t' ) lnb = i str(lnb + 1) = EOS return(lnb) end #-t- strim 257 ascii 15-Jan-84 15:07:19 #-h- tooldr 393 ascii 15-Jan-84 15:07:20 subroutine tooldr(dir, dtype) character dir(FILENAMESIZE) integer dtype ifdef(TREE_STRUCT_FILE_SYS) character temp(FILENAMESIZE) string suffix "tools/" enddef ifnotdef(TREE_STRUCT_FILE_SYS) call homdir(dir, dtype) elsedef call homdir(temp, PATH) call concat(temp, suffix, temp) if (dtype == PATH) call strcpy(temp, dir) else call mklocl(temp, dir) enddef return end #-t- tooldr 393 ascii 15-Jan-84 15:07:20 #-h- type 245 ascii 15-Jan-84 15:07:20 # ## type - determine type of character # integer function type (c) # # character c # # if ((c >= 'a' & c <= 'z') | (c >= 'A' & c <= 'Z')) # type = LETTER # else if (c >= '0' & c <= '9') # type = DIGIT # else # type = c # return # end #-t- type 245 ascii 15-Jan-84 15:07:20 #-h- upper 207 ascii 15-Jan-84 15:07:20 # ## upper - fold all alphas to upper case # subroutine upper (token) # # character token(ARB), cupper # integer i # # for (i=1; token(i) != EOS; i=i+1) # token(i) = cupper(token(i)) # return # end #-t- upper 207 ascii 15-Jan-84 15:07:20 #-h- wkday 340 ascii 15-Jan-84 15:07:21 # WkDay -- Get day-of-week corresponding to `month', `day', and `year'. integer function wkday( month, day, year) integer month, day, year integer lm, ld, ly lm = month - 2 ld = day ly = mod( year, 100) if( lm <= 0 ) { lm = lm + 12 ly = ly - 1 } wkday = mod( ld + ( 26 * lm - 2 ) / 10 + ly + ly / 4 - 34, 7) + 1 return end #-t- wkday 340 ascii 15-Jan-84 15:07:21 #-h- dstime 927 ascii 15-Jan-84 15:07:21 # dstime - determine whether date is day-light savings time or not # # this routine uses the following algorithm: # # if the month specified is > 4 (April) and < 10 (October), then YES # if the month specified is < 4 or > 10, then NO # if the month = 4, and the day is < the last Sunday, then NO # else YES # if the month = 10, and the day is < the last Sunday, then YES # else NO integer function dstime(date) integer date(7), i integer wkday if (date(2) > 4 & date(2) < 10) return(YES) else if (date(2) == 4) # April { for (i = 30; i > 0; i = i - 1) if (wkday(4, i, date(1)) == 1) # found Sunday break if (date(3) < i) return(NO) else return(YES) } else if (date(2) == 10) # October { for (i = 31; i > 0; i = i - 1) if (wkday(10, i, date(1)) == 1) # found Sunday break if (date(3) < i) return(YES) else return(NO) } else return(NO) end #-t- dstime 927 ascii 15-Jan-84 15:07:21 #-t- misc.r 26742 ascii 15-Jan-84 15:23:27 #-h- packsub.r 1661 ascii 15-Jan-84 15:23:32 #-h- inpack 182 ascii 15-Jan-84 15:08:01 ## InPack -- Initialze data for packing subroutines. subroutine inpack( nxtcol, rightm, buf, fd) filedes fd integer nxtcol, rightm character buf(ARB) nxtcol = 1 return end #-t- inpack 182 ascii 15-Jan-84 15:08:01 #-h- dopack 813 ascii 15-Jan-84 15:08:01 ## DoPack -- Pack words at TAB stops and flush lines as required. subroutine dopack( word, nxtcol, rightm, buf, fd) filedes fd integer i, j, nxtcol, nxttab, rightm integer length # function(s) character buf(ARB), word(ARB) if( nxtcol == 1 ) # must have at least one word/line call stcopy( word, 1, buf, nxtcol) else { i = length(buf) + 1 # next free array element nxttab = ( ( ( nxtcol - 1 ) / 16 + 1 ) * 16 ) + 1 # next tab stop j = nxttab + length(word) - 1 # last occupied column if( j > rightm ) { call flpack( nxtcol, rightm, buf, fd) i = 1 nxttab = nxtcol j = length(word) } if( ( nxttab - nxtcol ) > 8 ) call chcopy( '@t', buf, i) if( ( nxttab - nxtcol ) > 0 ) call chcopy( '@t', buf, i) call scopy( word, 1, buf, i) nxtcol = j + 1 } return end #-t- dopack 813 ascii 15-Jan-84 15:08:01 #-h- flpack 264 ascii 15-Jan-84 15:08:01 ## FlPack -- Flush buffer of packed words. subroutine flpack( nxtcol, rightm, buf, fd) filedes fd integer nxtcol, rightm character buf(ARB) if( nxtcol > 1 ) # something to flush { call putlin( buf, fd) call putch( '@n', fd) nxtcol = 1 } return end #-t- flpack 264 ascii 15-Jan-84 15:08:01 #-t- packsub.r 1661 ascii 15-Jan-84 15:23:32 #-h- pattern.r 15505 ascii 15-Jan-84 15:23:33 #-h- patdef 1084 ascii 15-Jan-84 15:08:32 ## definitions for the pattern matching routines # put on a file named 'defns' # Used by pattern.r and ed & sedit tools define(ANY,'?') define(BOL,'%') define(BOT,'{') define(CCL,'[') define(CCLEND,']') define(CHAR,'a') define(CLOSIZE,4) define(CLOSURE,'*') define(CLOSURE1,'+') # closure of one or more occurrences # i.e. (pat)+ == (pat)(pat)* define(COUNT,1) define(EOL,'$') define(EOT,'}') define(MAXTAG,10) define(NCCL,'n') define(PREVCL,2) define(START,3) define(DITTO,(-3)) define(SECTION,(-4)) define(NUMBER_REGISTER,(-5)) # code for number register # /ctag/ - common block to hold section limits for ch # put in a file called 'ctag' # Used by find, ch, and ed #common /ctag/ taglim(MAXTAG2) #integer taglim define(I_CTAG,common/ctag/taglim(arith(2,*,MAXTAG)) integer taglim) # /cnoreg/ - common block to hold number register for editor # put in a file called 'cnoreg' # used by ch and ed #common / cnoreg / noreg #integer noreg # number register for editor define(I_CNOREG,common/cnoreg/noreg; integer noreg) #-t- patdef 1084 ascii 15-Jan-84 15:08:32 #-h- addint 256 ascii 15-Jan-84 15:08:33 ### AddInt Put int into intara if it fits, increment j ## works with an array of integers integer function addint( int, intara, j, maxsiz) integer int, j, maxsiz, intara(maxsiz) if( j > maxsiz ) return(NO) intara(j) = int j = j + 1 return(YES) end #-t- addint 256 ascii 15-Jan-84 15:08:33 #-h- amatch 1141 ascii 15-Jan-84 15:08:33 ## AMatch -- Look for match starting at `lin(from)'. (non-recursive) integer function amatch( lin, from, pat) character lin(MAXLINE) integer omatch, patsiz # function(s) integer from, i, j, offset, pat(MAXPAT), stack stack = 0 offset = from # next unexamined input character for( j = 1 ; pat(j) != EOS ; j = j + patsiz( pat, j) ) { if( pat(j) == CLOSURE ) # a closure entry { stack = j j = j + CLOSIZE # step over CLOSURE for( i = offset ; lin(i) != EOS ; ) # match as many as if( omatch( lin, i, pat, j) == NO ) # possible break pat( stack + COUNT ) = i - offset pat( stack + START ) = offset offset = i # character that made us fail } else if( omatch( lin, offset, pat, j) == NO ) # non-closure { for( ; stack > 0 ; stack = pat( stack + PREVCL ) ) if( pat( stack + COUNT ) > 0 ) break if( stack <= 0 ) # stack is empty return(0) # return failure pat( stack + COUNT ) = pat( stack + COUNT ) - 1 j = stack + CLOSIZE offset = pat( stack + START ) + pat( stack + COUNT ) } } # else omatch succeeded return(offset) # success end #-t- amatch 1141 ascii 15-Jan-84 15:08:33 #-h- catsub 1265 ascii 15-Jan-84 15:08:33 ## CatSub -- Add replacement text to end of new. subroutine catsub( lin, from, to, sub, new, k, maxnew) integer addset, ctoi, itoc # function(s) integer from, i, j, junk, k, maxnew, to character c, lin(MAXLINE), new(maxnew), sub(MAXPAT) I_CTAG # include tag common block I_CNOREG # include noreg common block for( i = 1 ; sub(i) != EOS ; i = i + 1 ) { if( sub(i) == DITTO ) for( j = from ; j < to ; j = j + 1 ) junk = addset( lin(j), new, k, maxnew) else if( sub(i) == SECTION ) { i = i + 1 n = sub(i) if( n <= 0 | n > MAXTAG ) call error( "? In CatSub: illegal section" ) for( j = taglim( 2 * n - 1 ) ; j < taglim( 2 * n ) ; j = j + 1 ) junk = addset( lin(j), new, k, maxnew) } else if( sub(i) == NUMBER_REGISTER ) { k = k + itoc( noreg, new(k), maxnew - k + 1 ) i = i + 1 c = sub(i) if( c == '+' | c == '-' ) { i = i + 1 if( sub(i) != ' ' & sub(i) != '@t' ) { junk = ctoi( sub, i) if( junk == 0 ) junk = 1 } else junk = 1 if( c == '+' ) noreg = noreg + junk else noreg = noreg - junk } i = i - 1 # went one too far } else junk = addset( sub(i), new, k, maxnew) } return end #-t- catsub 1265 ascii 15-Jan-84 15:08:33 #-h- dodash 450 ascii 15-Jan-84 15:08:34 ## DoDash -- Expand array(i-1)-array(i+1) into set(j)... from valid . subroutine dodash( valid, array, i, set, j, maxset) character esc # function(s) integer addset, index # function(s) integer i, j, junk, k, limit, maxset character array(ARB), set(maxset), valid(ARB) i = i + 1 j = j - 1 limit = index( valid, esc( array, i) ) for( k = index( valid, set(j) ) ; k <= limit ; k = k + 1 ) junk = addset( valid(k), set, j, maxset) return end #-t- dodash 450 ascii 15-Jan-84 15:08:34 #-h- esc 802 ascii 15-Jan-84 15:08:34 ## Esc -- Map `array(i)' into escaped character, if appropriate. character function esc( array, i) character array(ARB), c character clower # function(s) integer i, j if( array(i) != ESCAPE ) esc = array(i) else if( array( i + 1 ) == EOS ) # ESCAPE not special at end esc = ESCAPE else { i = i + 1 c = clower( array(i) ) if( c == 'n' ) esc = '@n' else if( c == 't' ) esc = '@t' else if( c == 'r' ) esc = CR else if( c == 'b' ) esc = BACKSPACE else if( c == 'e' ) esc = EOS else if( c == 'f' ) esc = FF else if( c == 'l' ) esc = LF else if( c >= '0' & c <= '7' ) { esc = 0 for( j=i ; j < i+3 & ( array(j) >= '0' & array(j) <= '7' ) ; j=j+1 ) esc = 8 * esc + ( array(j) - '0' ) i = j - 1 } else esc = c } return end #-t- esc 802 ascii 15-Jan-84 15:08:34 #-h- filset 1037 ascii 15-Jan-84 15:08:34 ## FilSet -- Expand set at `array(i)' into `set(j)'; stop at `delim'. subroutine filset( delim, array, i, set, j, maxset) character esc # function(s) integer addset, index # function(s) integer i, j, junk, maxset character array(ARB), delim, set(maxset) string digits "0123456789" string lowalf "abcdefghijklmnopqrstuvwxyz" string upalf "ABCDEFGHIJKLMNOPQRSTUVWXYZ" for( ; array(i) != delim & array(i) != EOS ; i = i + 1 ) { if( array(i) == ESCAPE ) junk = addset( esc( array, i), set, j, maxset) else if( array(i) != '-' ) junk = addset( array(i), set, j, maxset) else if( j <= 1 | array( i + 1 ) == EOS ) # literal - junk = addset( '-', set, j, maxset) else if( index( digits, set( j - 1 ) ) > 0 ) call dodash( digits, array, i, set, j, maxset) else if( index( lowalf, set( j - 1 ) ) > 0 ) call dodash( lowalf, array, i, set, j, maxset) else if( index( upalf, set( j - 1 ) ) > 0 ) call dodash( upalf, array, i, set, j, maxset) else junk = addset( '-', set, j, maxset) } return end #-t- filset 1037 ascii 15-Jan-84 15:08:34 #-h- getccl 726 ascii 15-Jan-84 15:08:35 ## GetCCl -- Expand character class at `arg(i)' into `pat(j)'. integer function getccl( arg, i, pat, j) character arg(MAXARG), tpat(MAXPAT) integer addint # function(s) integer i, j, jstart, junk, k, int, pat(MAXPAT) i = i + 1 # skip over [ if( arg(i) == NOT ) { junk = addint( NCCL, pat, j, MAXPAT) i = i + 1 } else junk = addint( CCL, pat, j, MAXPAT) jstart = j junk = addint( 0, pat, j, MAXPAT) # leave room for count k = 1 call filset( CCLEND, arg, i, tpat, k, MAXPAT) tpat(k) = EOS for( k = 1 ; tpat(k) != EOS ; k = k + 1 ) { int = tpat(k) #cant pass char array junk = addint( int, pat, j, MAXPAT) } pat(jstart) = j - jstart - 1 if( arg(i) == CCLEND ) return(OK) else return(ERR) end #-t- getccl 726 ascii 15-Jan-84 15:08:35 #-h- getpat 215 ascii 15-Jan-84 15:08:35 ## GetPat -- Convert argument `arg' into pattern `pat'. integer function getpat( arg, pat) character arg(MAXARG) integer pat(MAXPAT) integer makpat # function(s) getpat = makpat( arg, 1, EOS, pat) return end #-t- getpat 215 ascii 15-Jan-84 15:08:35 #-h- getsub 203 ascii 15-Jan-84 15:08:35 ## GetSub -- Get substitution pattern into `sub'. integer function getsub( arg, sub) character arg(MAXARG), sub(MAXPAT) integer maksub # function(s) getsub = maksub( arg, 1, EOS, sub) return end #-t- getsub 203 ascii 15-Jan-84 15:08:35 #-h- locate 319 ascii 15-Jan-84 15:08:35 ## Locate -- Look for `c' in character class at `pat(offset)'. integer function locate( c, pat, offset) character c integer i, offset, pat(MAXPAT) # size of class is at pat(offset), characters follow for( i = offset + pat(offset) ; i > offset ; i = i - 1 ) if( c == pat(i) ) return(YES) return(NO) end #-t- locate 319 ascii 15-Jan-84 15:08:35 #-h- makpat 2087 ascii 15-Jan-84 15:08:36 ## MakPat -- Make pattern from `arg(from)', terminate at `delim'. integer function makpat( arg, from, delim, pat) character esc # function(s) character arg(MAXARG), delim integer addint, getccl, stclos # function(s) integer from, i, j, junk, lastcl, lastj, lj, pat(MAXPAT), int integer tagcnt, tagi, tagstk(MAXTAG) j = 1 # pat index lastj = 1 lastcl = 0 tagi = 0 tagcnt = 0 for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 ) { lj = j if( arg(i) == ANY ) junk = addint( ANY, pat, j, MAXPAT) else if( arg(i) == BOL & i == from ) junk = addint( BOL, pat, j, MAXPAT) else if( arg(i) == EOL & arg( i + 1 ) == delim ) junk = addint( EOL, pat, j, MAXPAT) else if( arg(i) == CCL ) { if( getccl( arg, i, pat, j) == ERR ) break } else if( ( arg(i) == CLOSURE | arg(i) == CLOSURE1 ) & i > from ) { lj = lastj if( pat(lj) == BOL | pat(lj) == EOL | pat(lj) == CLOSURE | pat(lj) == CLOSURE1 ) break # error if( arg(i) == CLOSURE1 ) # duplicate last pattern for( lastj = j ; lj < lastj ; lj = lj + 1 ) junk = addint( pat(lj), pat, j, MAXPAT) lastcl = stclos( pat, j, lastj, lastcl) } else if( arg(i) == BOT ) { if( tagi > MAXTAG | tagcnt > MAXTAG ) { # call remark("? Too many tags") break } tagcnt = tagcnt + 1 tagi = tagi + 1 tagstk(tagi) = tagcnt junk = addint( BOT, pat, j, MAXPAT) junk = addint( tagcnt, pat, j, MAXPAT) } else if( arg(i) == EOT ) { if( tagi <= 0 ) { # call remark("? Missing tag start symbol") break } n = tagstk(tagi) tagi = tagi - 1 junk = addint( EOT, pat, j, MAXPAT) junk = addint( n, pat, j, MAXPAT) } else { junk = addint( CHAR, pat, j, MAXPAT) int = esc(arg, i) junk = addint( int, pat, j, MAXPAT) } lastj = lj } if( arg(i) != delim ) # terminated early return(ERR) else if( addint( EOS, pat, j, MAXPAT) == NO ) # no room return(ERR) else if( tagi > 0 ) { # call remark("? Missing tag end symbol") return(ERR) } else return(i) end #-t- makpat 2087 ascii 15-Jan-84 15:08:36 #-h- maksub 937 ascii 15-Jan-84 15:08:36 ## MakSub -- Make substitution string in `sub'. integer function maksub( arg, from, delim, sub) character esc # function(s) character arg(MAXARG), delim, sub(MAXPAT) integer addset, ctoi, type # function(s) integer from, i, j, junk j = 1 for( i = from ; arg(i) != delim & arg(i) != EOS ; i = i + 1 ) { if( arg(i) == AND ) junk = addset( DITTO, sub, j, MAXPAT) else if( arg(i) == '$' & type( arg( i + 1 ) ) == DIGIT ) { i = i + 1 n = ctoi( arg, i) junk = addset( SECTION, sub, j, MAXPAT) junk = addset( n, sub, j, MAXPAT) i = i - 1 } else if( arg(i) == '$' & ( arg(i+1) == 'n' | arg(i+1) == 'N' ) ) { i = i + 1 junk = addset( NUMBER_REGISTER, sub, j, MAXPAT) } else junk = addset( esc( arg, i), sub, j, MAXPAT) } if( arg(i) != delim ) # missing delimiter maksub = ERR else if( addset( EOS, sub, j, MAXPAT) == NO ) # no room maksub = ERR else maksub = i return end #-t- maksub 937 ascii 15-Jan-84 15:08:36 #-h- match 268 ascii 15-Jan-84 15:08:36 ## Match -- Find match anywhere on line . integer function match( lin, pat) character lin(MAXLINE) integer amatch # function(s) integer i, pat(MAXPAT) for( i = 1 ; lin(i) != EOS ; i = i + 1 ) if( amatch( lin, i, pat) > 0 ) return(YES) return(NO) end #-t- match 268 ascii 15-Jan-84 15:08:36 #-h- omatch 1001 ascii 15-Jan-84 15:08:37 ## OMaTch -- try to match a single pattern at `pat(j)'. integer function omatch( lin, i, pat, j) character lin(MAXLINE) integer locate # function(s) integer bump, i, j, pat(MAXPAT) I_CTAG # include ctag common block omatch = NO if( lin(i) == EOS ) return bump = -1 if( pat(j) == CHAR ) { if( lin(i) == pat( j + 1 ) ) bump = 1 } else if( pat(j) == BOL ) { if( i == 1 ) bump = 0 } else if( pat(j) == ANY ) { if( lin(i) != '@n' ) bump = 1 } else if( pat(j) == EOL ) { if( lin(i) == '@n' ) bump = 0 } else if( pat(j) == CCL ) { if( locate( lin(i), pat, j + 1 ) == YES ) bump = 1 } else if( pat(j) == NCCL ) { if( lin(i) != '@n' & locate( lin(i), pat, j + 1 ) == NO ) bump = 1 } else if( pat(j) == BOT ) { n = pat( j + 1 ) taglim( 2 * n - 1 ) = i bump = 0 } else if( pat(j) == EOT ) { n = pat( j + 1 ) taglim( 2 * n ) = i bump = 0 } else call error( "? In omatch: cant happen" ) if( bump >= 0 ) { i = i + bump omatch = YES } return end #-t- omatch 1001 ascii 15-Jan-84 15:08:37 #-h- patsiz 443 ascii 15-Jan-84 15:08:37 ## PatSiz -- Return size of pattern entry at `pat(n)'. integer function patsiz( pat, n) integer n, pat(MAXPAT) if( pat(n) == CHAR | pat(n) == BOT | pat(n) == EOT ) patsiz = 2 else if( pat(n) == BOL | pat(n) == EOL | pat(n) == ANY ) patsiz = 1 else if( pat(n) == CCL | pat(n) == NCCL ) patsiz = pat( n + 1 ) + 2 else if( pat(n) == CLOSURE ) # optional patsiz = CLOSIZE else call error( "? In patsiz: cant happen" ) return end #-t- patsiz 443 ascii 15-Jan-84 15:08:37 #-h- stclos 571 ascii 15-Jan-84 15:08:37 ## StClos -- Insert closure entry at `pat(j)'. integer function stclos( pat, j, lastj, lastcl) integer addint # function(s) integer j, jp, jt, junk, lastcl, lastj, pat(MAXPAT) for( jp = j - 1 ; jp >= lastj ; jp = jp - 1 ) # make a hole { jt = jp + CLOSIZE junk = addint( pat(jp), pat, jt, MAXPAT) } j = j + CLOSIZE stclos = lastj junk = addint( CLOSURE, pat, lastj, MAXPAT) # put closure in it junk = addint( 0, pat, lastj, MAXPAT) # COUNT junk = addint( lastcl, pat, lastj, MAXPAT) # PREVCL junk = addint( 0, pat, lastj, MAXPAT) # START return end #-t- stclos 571 ascii 15-Jan-84 15:08:37 #-h- gnoreg 77 ascii 15-Jan-84 15:08:37 subroutine gnoreg(value) integer value I_CNOREG value = noreg return end #-t- gnoreg 77 ascii 15-Jan-84 15:08:37 #-h- snoreg 77 ascii 15-Jan-84 15:08:38 subroutine snoreg(value) integer value I_CNOREG noreg = value return end #-t- snoreg 77 ascii 15-Jan-84 15:08:38 #-t- pattern.r 15505 ascii 15-Jan-84 15:23:33 #-h- pb.r 1509 ascii 15-Jan-84 15:23:36 #-h- ngetch 317 ascii 15-Jan-84 15:09:08 # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd PB_DECL(1) if (pbp > 0) { c = pbbuf(pbp) pbp = pbp - 1 } else if (fd == ERR) c = EOF else c = getch(c, fd) ngetch = c return end #-t- ngetch 317 ascii 15-Jan-84 15:09:08 #-h- pbinit 85 ascii 15-Jan-84 15:09:08 subroutine pbinit(size) integer size PB_DECL(1) pbp = 0 pbsize = size return end #-t- pbinit 85 ascii 15-Jan-84 15:09:08 #-h- putbak 232 ascii 15-Jan-84 15:09:08 # putbak - push character back onto input subroutine putbak(c) character c PB_DECL(1) pbp = pbp + 1 if (pbp > pbsize) call error("putbak - too many characters pushed back") pbbuf(pbp) = c return end #-t- putbak 232 ascii 15-Jan-84 15:09:08 #-h- pbstr 339 ascii 15-Jan-84 15:09:09 # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i PB_DECL(1) for (i = length(in); i > 0; i = i - 1) { pbp = pbp + 1 if (pbp > pbsize) call error("pbstr - too many characters pushed back") pbbuf(pbp) = in(i) } return end #-t- pbstr 339 ascii 15-Jan-84 15:09:09 #-t- pb.r 1509 ascii 15-Jan-84 15:23:36 #-h- rawpmt.r 11048 ascii 15-Jan-84 15:23:36 #-h- defns 660 ascii 15-Jan-84 15:09:37 define(BELL,7) # ^G define(CARRIAGERETURN,13) # CR define(ENDOFFILE,26) # ^Z define(ESC,27) # ASCII ESC define(RETYPELINE,18) # ^R define(VERIFYLINE,22) # ^V define(LINEDELETE,21) # ^U define(RUBOUT,127) # DEL | RUB define(WORDDELETE,23) # ^W define(DIRECTORYLIST,4) # ^D define(RECOGNIZEFILE,6) # ^F define(EXPAND,YES) define(NO_EXPAND,NO) # # the following definitions are to prevent overloading the global name space # define(ds,praw01) define(insstr,praw02) define(lngest,praw03) define(rawio,praw04) define(recogf,praw05) define(redisp,praw06) define(rwpmpt,praw07) define(scnbck,praw08) define(spawnd,praw09) define(spnbck,praw10) #-t- defns 660 ascii 15-Jan-84 15:09:37 #-h- rawpmt 433 ascii 15-Jan-84 15:09:37 integer function rawpmt(pstr, lin, in) character pstr(ARB), lin(MAXLINE), tmp(MAXLINE) integer in, n integer rwpmpt string altpst " _" altpst(1) = pstr(1) n = rwpmpt(pstr, lin, in) if (n == EOF | n == 1) return(n) while (lin(n) == '@n' & lin(n-1) == ESCAPE) { lin(n-1) = ' ' # @'@n' => ' ' if (rwpmpt(altpst, tmp, in) == EOF) return(EOF) call stcopy(tmp, 1, lin, n) n = n - 1 # point at '@n' } return(n) end #-t- rawpmt 433 ascii 15-Jan-84 15:09:37 #-h- ds 976 ascii 15-Jan-84 15:09:38 ## ds - perform directory search for longest string matching `inpstr'. integer function ds(inpstr, outstr) integer found, len, depth, ptr(MAXDIRECTS), j, junk, desc integer length, gtftok, opendr, gdrprm, equal, lngest character inpstr(ARB), outstr(ARB), path(FILENAMESIZE), pat(FILENAMESIZE), c string star "*" found = 0 len = length(inpstr) if (len == 0 | inpstr(len) == '/') call concat(inpstr, star, pat) else call strcpy(inpstr, pat) call mkpath(pat, path) call fold(path) call exppth(path, depth, ptr, pat) j = ptr(depth) pat(1) = EOS junk = gtftok(path, j, pat) j = ptr(depth) path(j) = EOS if (opendr(path, desc) == ERR) return(found) len = length(pat) + 1 while (gdrprm(desc, path) != EOF) { c = path(len) path(len) = EOS if (equal(path, pat) == NO & pat(1) != '*') next path(len) = c if (found == 0) call strcpy(path, outstr) found = found + 1 j = lngest(path, outstr) + 1 outstr(j) = EOS } call closdr(desc) return(found) end #-t- ds 976 ascii 15-Jan-84 15:09:38 #-h- insstr 326 ascii 15-Jan-84 15:09:38 ## insstr - insert string `s1' at position `i' of string `s2'. subroutine insstr(s1, s2, i) character s1(ARB), s2(ARB) integer i, j, k, l integer length k = length(s2) + 1 for (j=k+length(s1); k >= i; k=k-1) { s2(j) = s2(k) j = j - 1 } l = 1 for (k=i; k <= j; k=k+1) { s2(k) = s1(l) l = l + 1 } return end #-t- insstr 326 ascii 15-Jan-84 15:09:38 #-h- lngest 240 ascii 15-Jan-84 15:09:38 ## lngest - return length of the longest substring common to two strings integer function lngest(s1, s2) integer i character s1(ARB), s2(ARB) for (i=1; s1(i) == s2(i); i=i+1) if (s1(i) == EOS | s2(i) == EOS) break return(i-1) end #-t- lngest 240 ascii 15-Jan-84 15:09:38 #-h- rawio 585 ascii 15-Jan-84 15:09:38 ## rawio - determine if rawpmt can be used on unit integer function rawio(in, out, savmod) integer in, out, savmod integer create, stmode, isatty, gtmode string ttystr TTY_NAME if (out == EOF) # need to open echo unit { out = create(ttystr, WRITE) if (out != ERR) if (stmode(out, RARE) != RARE) { call close(out) out = ERR } } rawio = NO if (isatty(in) == YES & out != ERR) { savmod = gtmode(in) # save current mode if (stmode(in, RARE) == RARE) # can do rare mode rawio = YES else savmod = stmode(in, savmod) } return end #-t- rawio 585 ascii 15-Jan-84 15:09:38 #-h- recogf 426 ascii 15-Jan-84 15:09:39 ## recogf - recognize longest unique filename substring matching %`str'. ## complete the string in `str'. integer function recogf(str) integer i integer ds, length character str(ARB), outstr(FILENAMESIZE) i = length(str) if (i > 0) repeat { if (str(i) == '/' | str(i) == '\') break i = i - 1 } until (i == 0) recogf = ds(str, outstr) if (recogf != 0) call scopy(outstr, 1, str, i+1) return end #-t- recogf 426 ascii 15-Jan-84 15:09:39 #-h- redisp 761 ascii 15-Jan-84 15:09:39 ## redisp - redisplay prompt and line on int, expanding control characters ## as required subroutine redisp(pstr, lin, int, temp, ifexpd) character pstr(ARB), lin(ARB), temp(ARB) integer int, ifexpd, i, j string crlf "@r@l" i = 1 while (pstr(i) != EOS) { for (j=1; pstr(i) != '@n' & pstr(i) != EOS; j=j+1) { temp(j) = pstr(i) i = i + 1 } if (pstr(i) == '@n') { call scopy(crlf, 1, temp, j) i = i + 1 } else temp(j) = EOS call putlin(temp, int) } j = 1 for (i=1; lin(i) != EOS; i=i+1) { if (lin(i) < ' ') { call chcopy('^', temp, j) if (ifexpd == EXPAND) call chcopy(lin(i)+'@@', temp, j) } else call chcopy(lin(i), temp, j) } temp(j) = EOS call putlin(temp, int) return end #-t- redisp 761 ascii 15-Jan-84 15:09:39 #-h- rwpmpt 3331 ascii 15-Jan-84 15:09:39 integer function rwpmpt(pstr, lin, in) character pstr(ARB), lin(MAXLINE), c, tmp(MAXLINE) character getch integer in, i, j, k, l, out, savmod integer prompt, scnbck, spnbck, length, recogf, index, rawio, stmode string bol "%" string dstr "fd " string bsblbs "@b @b" string crlf "@r@l" string ctrld "^Directory list@r" string ctrlr "^Retype line@r@l" string ctrlu "^Undo line@r@l" string ctrlv "^Verify line@r@l" string ctrlz "^Z@r" string fldtrm " @t/\@@<>" # terminator string for field of pathname string filtrm " <>@@" # terminator string for filenames string pthtrm " /\" # terminator string for pathnames string valctl "@f@t" # valid control characters data out /EOF/ if (rawio(in, out, savmod) == NO) return(prompt(pstr, lin, in)) i = 1 call putlin(crlf, out) call redisp(pstr, EOS, out, tmp, NO_EXPAND) lin(1) = EOS repeat { c = getch(c, in) if (c == ENDOFFILE) { call putlin(ctrlz, out) lin(1) = EOS return(EOF) } else if (c == CARRIAGERETURN) break else if (c == BACKSPACE | c == RUBOUT) { if (i > 1) { call putlin(bsblbs, out) i = i - 1 lin(i) = EOS } else lin(i) = EOS } else if (c == LINEDELETE) { call putlin(ctrlu, out) call redisp(pstr, EOS, out, tmp, NO_EXPAND) i = 1 lin(i) = EOS } else if (c == RETYPELINE) { call putlin(ctrlr, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == VERIFYLINE) { call putlin(ctrlv, out) call redisp(pstr, lin, out, tmp, EXPAND) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == WORDDELETE) { i = spnbck(lin, i, bsblbs, out, fldtrm) i = scnbck(lin, i, bsblbs, out, fldtrm) lin(i) = EOS } else if (c == DIRECTORYLIST) { call putlin(ctrld, out) call spawnd(dstr) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } else if (c == RECOGNIZEFILE) { lin(i) = EOS j = scnbck(lin, i, EOS, out, filtrm) call scopy(lin, j, tmp, 1) k = length(tmp) + 1 l = recogf(tmp) if (l != 0) { if (tmp(k) != EOS | l == 1) # Progress was made { if (tmp(k) != EOS) call scopy(tmp, k, lin, i) else { lin(i) = ' ' lin(i+1) = EOS } call putlin(lin(i), out) i = length(lin) + 1 } else { k = 1 call stcopy(dstr, 1, tmp, k) call scopy(lin, j, tmp, k) j = scnbck(tmp(k), length(tmp(k))+1, EOS, out, pthtrm) + k - 1 call insstr(bol, tmp, j) call putlin(crlf, out) call putch('#', out) call putlin(tmp, out) call putch(CARRIAGERETURN, out) call spawnd(tmp) call putlin(crlf, out) call redisp(pstr, lin, out, tmp, NO_EXPAND) } } else call putch(BELL, out) } else if (c < ' ' & index(valctl, c) == 0) call putch(BELL, out) else { lin(i) = c i = i + 1 lin(i) = EOS if (index(valctl, c) == 0) call putch(c, out) else call putch('^', out) # all characters occupy one column } } call putch(CARRIAGERETURN, out) lin(i) = '@n' lin(i+1) = EOS savmod = stmode(in, savmod) # reset mode on unit return(i) end #-t- rwpmpt 3331 ascii 15-Jan-84 15:09:39 #-h- scnbck 684 ascii 15-Jan-84 15:09:40 ## scnbck - scan backwards until a terminator or boundary is reached. ## return the index of the last character scanned before terminator. ## output string `rubstr' on `chn' as each character is scanned. integer function scnbck(str, col, rubstr, chn, trmara) integer i, chn, col integer index character rubstr(ARB), str(ARB), trmara(ARB) if (col > 1) { i = col - 1 # point to last char entered. for ( ; index(trmara, str(i)) == 0 & i > 1; i=i-1) if (rubstr(1) != EOS) call putlin(rubstr, chn) if (i == 1 & index(trmara, str(i)) == 0) { if (rubstr(1) != EOS) call putlin(rubstr, chn) } else i = i + 1 } else i = 1 return(i) end #-t- scnbck 684 ascii 15-Jan-84 15:09:40 #-h- spawnd 362 ascii 15-Jan-84 15:09:40 subroutine spawnd(args) character args(ARB), image(FILENAMESIZE), pid(PIDSIZE) integer loccom, spawn integer junk, init string d "fd" string spath "@e~usr/@e~bin/@e@n" string suffix IMAGE_SUFFIX data init /YES/ if (init == YES) { init = NO junk = loccom(d, spath, suffix, image) } junk = spawn(image, args, pid, WAIT) return end #-t- spawnd 362 ascii 15-Jan-84 15:09:40 #-h- spnbck 656 ascii 15-Jan-84 15:09:40 ## spnbck - span backwards until a non-separator or boundary is reached. ## return the index of the last character scanned before separator, ## output string `rubstr' on `chn' as each character is scanned. integer function spnbck(str, col, rubstr, chn, separa) integer i, chn, col integer index character rubstr(ARB), str(ARB), separa(ARB) if (col > 1) { i = col - 1 # point to last char entered. for ( ; index(separa, str(i)) > 0 & i > 1; i=i-1) if (rubstr(1) != EOS) call putlin(rubstr, chn) if (i == 1) { if (rubstr(1) != EOS) call putlin(rubstr, chn) } else i = i + 1 } else i = 1 return(i) end #-t- spnbck 656 ascii 15-Jan-84 15:09:40 #-t- rawpmt.r 11048 ascii 15-Jan-84 15:23:36 #-h- tabsubs.r 2464 ascii 15-Jan-84 15:23:39 #-h- argtab 401 ascii 15-Jan-84 15:10:09 ## ArgTab -- Fetch tab information from argument list. subroutine argtab(buf) character buf(MAXLINE), n(4) integer i, j, k integer getarg, alldig # function(s) i = 1 for( j = 1 ; getarg( j, n, 4) != EOF ; j = j + 1 ) { k = 1 if( n(1) == '+' ) k = k + 1 if( alldig( n(k) ) == YES ) { if( i > 1 ) call chcopy( ' ', buf, i) call stcopy( n, 1, buf, i) } } return end #-t- argtab 401 ascii 15-Jan-84 15:10:09 #-h- gtword 623 ascii 15-Jan-84 15:10:10 ## GtWord -- Get next word from `in(i)' into `out'; incr `i' to `size' chars. integer function gtword( in, i, out, size) character in(ARB), out(ARB) integer i, size, j, overfl while( in(i) == ' ' | in(i) == '@t' ) i = i + 1 overfl = YES # assume word too big for( j = 1 ; j <= size ; j = j + 1 ) { if( in(i) == EOS | in(i) == ' ' | in(i) == '@t' | in(i) == '@n' ) { overfl = NO break } else { out(j) = in(i) i = i + 1 } } out(j) = EOS if( overfl == YES ) # skip extra characters while( in(i) != EOS & in(i) != ' ' & in(i) != '@t' & in(i) != '@n' ) i = i + 1 return( j - 1 ) end #-t- gtword 623 ascii 15-Jan-84 15:10:10 #-h- settab 711 ascii 15-Jan-84 15:10:10 ## SetTab -- Set initial tab stops. subroutine settab( buf, tabs) integer i, j, k, l, m, p, ptr, tabs(MAXLINE) integer alldig, ctoi, gtword # function(s) character n(4), buf(MAXLINE) p = 0 for( i = 1 ; i <= MAXLINE ; i = i + 1 ) tabs(i) = NO ptr = 1 for( j = 1 ; gtword( buf, ptr, n, 4) > 0 ; j = j + 1 ) { k = 1 if( n(1) == '+' ) k = k + 1 if( alldig( n(k) ) == NO ) next l = ctoi( n, k) if( l <= 0 | l > MAXLINE ) next if( n(1) != '+' ) { p = l tabs(p) = YES } else { if( p == 0 ) p = l + 1 for( m = p ; m <= MAXLINE ; m = m + l ) tabs(m) = YES } } if( p == 0 ) { for( i = 9 ; i <= MAXLINE ; i = i + 8 ) tabs(i) = YES } return end #-t- settab 711 ascii 15-Jan-84 15:10:10 #-h- tabpos 193 ascii 15-Jan-84 15:10:10 ## TabPos -- Return YES if `col' is a tab stop. integer function tabpos( col, tabs) integer col, i, tabs(MAXLINE) if( col > MAXLINE ) tabpos = YES else tabpos = tabs(col) return end #-t- tabpos 193 ascii 15-Jan-84 15:10:10 #-t- tabsubs.r 2464 ascii 15-Jan-84 15:23:39 #-h- tb.r 1811 ascii 15-Jan-84 15:23:40 #-h- tbsym 51 ascii 15-Jan-84 15:10:36 define(INCLUDE_CTB,common/ctb/table pointer table) #-t- tbsym 51 ascii 15-Jan-84 15:10:36 #-h- tbinit 231 ascii 15-Jan-84 15:10:36 ## TbInit -- Initialize simple lookup table. subroutine tbinit(size) integer size INCLUDE_CTB pointer mktabl call dsinit(size) # initialize dynamic storage table = mktabl(1) # create symbol table in dynamic storage return end #-t- tbinit 231 ascii 15-Jan-84 15:10:36 #-h- tbinst 544 ascii 15-Jan-84 15:10:36 ## TbInst -- Enter a new symbol definition, discarding any old one. subroutine tbinst( name, defn) character name(ARB), defn(ARB) INCLUDE_CTB integer lookup, enter # function(s) pointer text pointer sdupl if( lookup( name, text, table) == YES ) call dsfree(text) # this is how to do UNDEFINE, by the way text = sdupl(defn) # store definition away if( text != LAMBDA ) # succeeded { if( enter( name, text, table) == OK ) return else call dsfree(text) } call remark( "? In tbinst: no room for new definition" ) return end #-t- tbinst 544 ascii 15-Jan-84 15:10:36 #-h- tblook 449 ascii 15-Jan-84 15:10:36 ## TbLook -- Look up a defined identifier, return its definition. integer function tblook( id, defn) character id(ARB), defn(ARB) INCLUDE_CTB DS_DECL( Mem, 1) integer i, j integer lookup # function(s) pointer locn tblook = lookup( id, locn, table) if( tblook == YES ) { i = 1 for( j = cvt_to_cptr(locn) ; cMem(j) != EOS ; j = j + 1 ) { defn(i) = cMem(j) i = i + 1 } defn(i) = EOS } else defn(1) = EOS return end #-t- tblook 449 ascii 15-Jan-84 15:10:36 #-t- tb.r 1811 ascii 15-Jan-84 15:23:40 #-h- lnedit.all 62860 ascii 15-Jan-84 15:23:41 #-h- lnedit.inc 2195 ascii 15-Jan-84 15:16:46 #-h- cledit 1486 ascii 15-Jan-84 15:13:46 ## CLEdit - Common block for intra-line editing routines. common /cledit/ hastab, lc1, nc, nmaxpc, npc, oc, omaxpc, opc, pc1, qp, tabs(MAXLINE), undcur, fl(MAXLINE), nl(MAXLINE), npl(MAXLINE), ol(MAXLINE), opl(MAXLINE), oq(MAXLINE), tmplin(MAXLINE), undlin(MAXLINE) integer hastab # YES if output device has hardware tabs integer lc1 # First logical character after prompt integer nc # New logical cursor position integer nmaxpc # New maximum physical cursor position written integer npc # New physical cursor position integer oc # Old logical cursor position integer omaxpc # Old maximum physical column written integer opc # Old physical cursor position integer pc1 # First physical character after prompt integer qp # Pointer to next char in output queue integer tabs # Array of tab stops -- YES(set) | NO(reset) integer undcur # Logical cursor postion of line in `undo' buffer character fl # Full logical line (with prompt) character nl # New logical line character npl # New physical line character ol # Old logical line character opl # Old physical line character oq # Output queue for line refreshing character tmplin # Scratch line buffer character undlin # Line in `undo' buffer # Note: All the line editing routines expect to have `ol' and # `oc' set to the current state of the line on the screen # when they are invoked. All routines are expected to export # `nl' and `nc' as the (desired) state of the line on the screen. #-t- cledit 1486 ascii 15-Jan-84 15:13:46 #-h- clpb 103 ascii 15-Jan-84 15:13:46 common / clpb / pbp, pbbuf(PB_SIZE) integer pbp # buffer pointer character pbbuf # push back buffer #-t- clpb 103 ascii 15-Jan-84 15:13:46 #-h- coldcm 204 ascii 15-Jan-84 15:13:47 # /coldcm/ - common block holding `last command stack' for shell # put on a file named `colccm' # used only by the shell common /coldcm/ oldcmd(MAXLINE) character oldcmd # just one line held for now... #-t- coldcm 204 ascii 15-Jan-84 15:13:47 #-t- lnedit.inc 2195 ascii 15-Jan-84 15:16:46 #-h- lnedit.r 43925 ascii 15-Jan-84 15:16:47 #-h- defns 1404 ascii 15-Jan-84 15:15:26 ## defns - Definitions for intra-line editing. define(APPENDPREV,1) # ^A define(DIRECTORYLIST,4) # ^D define(EDITLINE,5) # ^E define(ENDOFFILE,26) # ^Z define(LINEDELETE,21) # ^U define(RECOGNIZEFILE,6) # ^F define(RETYPELINE,18) # ^R define(WORDDELETE,23) # ^W define(PB_SIZE,512) # push back buffer size # The following definitions are required to avoid potential name # conflicts in `rlib'. define(alphan,le_alphan) define(bckupc,le_bckupc) define(d2eol,le_d2eol) define(dnoise,le_dnoise) define(ds,le_ds) define(fclosd,le_fclosd) define(fgdrpr,le_fgdrpr) define(flushq,le_flushq) define(fopend,le_fopend) define(gthist,le_gthist) define(insstr,le_insstr) define(ledit,le_ledit) define(leinit,le_leinit) define(lerror,le_lerror) define(ll2pl,le_ll2pl) define(lngest,le_lngest) define(mvcurq,le_mvcurq) define(ngetch,le_ngetch) define(ngtnum,le_ngtnum) define(pbcmd,le_pbcmd) define(pbinit,le_pbinit) define(pbstr,le_pbstr) define(putbak,le_putbak) define(putchf,le_putchf) define(putchq,le_putchq) define(putstf,le_putstf) define(putstq,le_putstq) define(rawio,le_rawio) define(rawtxt,le_rawtxt) define(recogf,le_recogf) define(saveln,le_saveln) define(scn4ch,le_scn4ch) define(scnbbw,le_scnbbw) define(scnbck,le_scnbck) define(scnblw,le_scnblw) define(scnebw,le_scnebw) define(scnelw,le_scnelw) define(spawnd,le_spawnd) define(spnbck,le_spnbck) define(updlin,le_updlin) define(whites,le_whites) #-t- defns 1404 ascii 15-Jan-84 15:15:26 #-h- lnedit 4856 ascii 15-Jan-84 15:15:27 ## LnEdit - Prompt for command line, with unCOOKED editing. integer function lnedit( pstr, lin, ichn) include coldcm integer cmdnum, i, ichn, imode, j, junk, k, len, ochn, omode, savmod integer index, length, prompt, recogf, scnbck, spawn, spnbck, stmode, isatty integer gthist, rawio character lin(ARB), pid(PIDSIZE), pstr(ARB), tmp(FILENAMESIZE) character c character ledit character bsblbs(4), crlf(3), ctrlr(5), ctrlu(5), ctrlz(5) character rubcmd(4), wrdrub(6) character ngetch string bol "%" string dstr "d " string pthtrm " /\" # Terminator array for backscan string filtrm " ,<>@@" # Terminator string for filename string fldtrm " /\@@~>" # Terminator string for field of path data bsblbs/BACKSPACE, ' ', BACKSPACE, EOS/ data crlf/CR, LF, EOS/ data ctrlr/'^', 'R', CR, LF, EOS/ data ctrlu/'^', 'U', CR, LF, EOS/ data ctrlz/'^', 'Z', CR, LF, EOS/ data rubcmd/EDITLINE, 'x', ENDOFFILE, EOS/ data wrdrub/' ', EDITLINE, 'B', 'D', ENDOFFILE, EOS/ data ochn /EOF/ if( rawio( ichn, ochn, savmod) == NO ) # Can't do unCOOKED io. return( prompt( pstr, lin, ichn)) i = 1 call putlin( crlf, ochn) call putlin( pstr, ochn) lin(1) = EOS repeat { c = ngetch( c, ichn) if( c == ENDOFFILE ) { call putlin( ctrlz, ochn) lnedit = EOF lin(1) = EOS return } else if( c == CR ) # CARRIAGE_RETURN break else if( c == LF ) call putch( LF, ochn) else if( c == BACKSPACE | c == RUBOUT ) { if( i > 1 ) { if( lin(i-1) == '@t' ) call pbstr( rubcmd) else { call putlin(bsblbs, ochn) i = i - 1 lin(i) = EOS } } else lin(i) = EOS } else if( c == LINEDELETE ) { call putlin( ctrlu, ochn) call putlin( pstr, ochn) i = 1 lin(i) = EOS } else if( c == RETYPELINE ) { call putlin( ctrlr, ochn) lin(i) = EOS call putlin( pstr, ochn) call putlin( lin, ochn) } else if( c == WORDDELETE ) { call pbstr( wrdrub) # i = spnbck( lin, i, bsblbs, ochn, fldtrm) # i = scnbck( lin, i, bsblbs, ochn, fldtrm) # lin(i) = EOS } else if( c == RECOGNIZEFILE | c == ESC ) { lin(i) = EOS j = scnbck( lin, i, EOS, ochn, filtrm) call scopy( lin, j, tmp, 1) len = length(tmp) if( recogf(tmp) != ERR ) { if( tmp(len+1) != EOS ) # Progress was made... { call scopy( tmp, len+1, lin, i) call putlin( lin(i), ochn) i = length(lin) + 1 } else { j = scnbck( lin, i, EOS, ochn, filtrm) k = 1 call stcopy( dstr, 1, tmp, k) call scopy( lin, j, tmp, k) j = scnbck( tmp(k), length(tmp(k))+1, EOS, ochn, pthtrm) + k - 1 call insstr( bol, tmp, j) call putlin( crlf, ochn) call spawnd( tmp) call putlin( crlf, ochn) call putlin( pstr, ochn) lin(i) = EOS call putlin( lin, ochn) } } else call putch( BELL, ochn) } else if( c == DIRECTORYLIST ) { call putlin( "^Directory", ochn) call putlin( crlf, ochn) call spawnd( dstr) call putlin( crlf, ochn) call putlin( pstr, ochn) lin(i) = EOS call putlin( lin, ochn) } else if( c == APPENDPREV ) { if( lin(1) == '!' ) # Retrieve line from history. i = gthist( lin, i) else { i = 1 call stcopy( oldcmd, 1, lin, i) } call putlin( "^Append", ochn) call putlin( crlf, ochn) call putlin( pstr, ochn) call putlin( lin, ochn) } else if( c == EDITLINE ) { if( (i == 1 & lin(i) == EOS) | lin(1) == '!' ) { if( lin(1) == '!' ) # Retrieve command from history. { i = gthist( lin, i) i = 1 call putlin( crlf, ochn) call putlin( pstr, ochn) } else call strcpy( oldcmd, lin) # Retrieve previous command. call putlin( lin, ochn) call putch( CR, ochn) call putlin( pstr, ochn) } else if( i > 1 ) { i = i - 1 call putch( BACKSPACE, ochn) } c = ledit( pstr, lin, i, ichn, ochn) if( lin(i) != EOS ) { call putch( lin(i), ochn) i = i + 1 } if( c == CR ) # CARRIAGE_RETURN break } else if( c == VT ) # Pump out 8 LFs for a Vertical '@t'. for( j = 1 ; j <= 8 ; j = j + 1 ) call putch( LF, ochn) else if( c == FF ) # Pump out 24 LFs for a Form Feed. for( j = 1 ; j <= 24 ; j = j + 1 ) call putch( LF, ochn) else if( c < ' ' & c != '@t' ) # No control chars, please... call putch( BELL, ochn) else { lin(i) = c i = i + 1 lin(i) = EOS call putch( c, ochn) } } call putch( CR, ochn) #call putlin( crlf, ochn) if( lin(1) != EOS ) # Save command for reedit. { lin(i) = EOS call strcpy( lin, oldcmd) } lin(i) = '@n' lin(i+1) = EOS savmod = stmode( ichn, savmod) # reset mode on unit return(i) end #-t- lnedit 4856 ascii 15-Jan-84 15:15:27 #-h- alphan 210 ascii 15-Jan-84 15:15:27 ## AlphaN - Return YES if c is a LETTER or DIGIT, NO otherwise. integer function alphan(c) character c integer type if( type(c) == LETTER | type(c) == DIGIT ) alphan = YES else alphan = NO return end #-t- alphan 210 ascii 15-Jan-84 15:15:27 #-h- bckupc 647 ascii 15-Jan-84 15:15:28 ## BckUpC - Back up a character position; erase char if `erase' == YES. subroutine bckupc( ochn, erase) character c integer erase, i, ochn integer tabpos include cledit character bs(2), bsblbs(4), rubstr(4) data bs /BACKSPACE, EOS/ data bsblbs /BACKSPACE, ' ', BACKSPACE, EOS/ if( erase == YES ) call strcpy( bsblbs, rubstr) else call strcpy( bs, rubstr) c = opl(opc-1) if( c == '@t' ) { call putstq( bs, ochn) i = opc for( ; tabpos( i, tabs) == NO & i > 1 & opl(i-1) == '@t' ; i = i - 1 ) call putstq( bs, ochn) } else if( c == ' ' ) call putstq( bs, ochn) else call putstq( rubstr, ochn) return end #-t- bckupc 647 ascii 15-Jan-84 15:15:28 #-h- d2eol 272 ascii 15-Jan-84 15:15:28 ## D2EOL - Delete to End-of-line (omaxpc) on `ochn'. integer function d2eol( ochn) integer i, i1, i2, ochn include cledit i1 = opc i2 = omaxpc for( i = i1 ; i <= i2 ; i = i + 1 ) call putchq( ' ', ochn) d2eol = i2 - i1 + 1 # Number of blanks we output. return end #-t- d2eol 272 ascii 15-Jan-84 15:15:28 #-h- dnoise 726 ascii 15-Jan-84 15:15:29 ## DNoise - Remove noise from filename `fil'. Noise is defined as: ## version numbers of `1', trailing `.', and `.dir' extensions. ## Return YES/NO if `fil' is a `.dir' file. integer function dnoise( fil) character fil(ARB) integer i, isdir integer equal, length # function(s) string dot1 ".1" string dotdir ".dir" i = length( fil) if( i > 2 ) if( equal( fil(i-1), dot1) ) # Remove trailing ".1" { i = i - 2 fil(i+1) = EOS } if( fil(i) == '.' & i != 1 ) # Remove trailing "." { fil(i) = EOS i = i - 1 } isdir = NO if( i > 3 ) if( equal( fil(i-3), dotdir) ) # Replace ".dir" with "/". { i = i - 3 fil(i) = '/' fil(i+1) = EOS isdir = YES } dnoise = isdir return end #-t- dnoise 726 ascii 15-Jan-84 15:15:29 #-h- ds 1077 ascii 15-Jan-84 15:15:29 integer function ds( inpstr, outstr) character buf(MAXLINE), name(FILENAMESIZE), direc(FILENAMESIZE) character pat(MAXLINE), path(FILENAMESIZE), tmpnam(FILENAMESIZE) character inpstr(ARB), outstr(ARB) integer j, i, junk, gtftok, dirfid, dnoise integer fgdrpr, fopend, found, length integer depth, ptr(10) integer len, equal, lngest, patlen found = NO len = length(inpstr) if( len == 0 | inpstr(len) == '/' ) { inpstr(len+1) = '*' inpstr(len+2) = EOS } call fold(inpstr) call resdef( inpstr, path) call exppth(path, depth, ptr, buf) j = ptr(depth) pat(1) = EOS junk = gtftok(path, j, pat) j = ptr(depth) path(j) = EOS call dirfil(path, name, direc) if( fopend( name, dirfid) == ERR ) { ds = NO return } patlen = length(pat) while( fgdrpr( dirfid, name) == OK ) { call strcpy( name, tmpnam) tmpnam(patlen+1) = EOS if( equal( tmpnam, pat) == NO & pat(1) != '*' ) next junk = dnoise( name) if( found == NO ) { call strcpy( name, outstr) found = YES } i = lngest( name, outstr) outstr(i+1) = EOS } call fclosd( dirfid) ds = found return end #-t- ds 1077 ascii 15-Jan-84 15:15:29 #-h- fclosd 213 ascii 15-Jan-84 15:15:29 ## FClosD - (VMS) Close directory file opened as `fd'. ## Use this version until `fgdrpr' & co. are taught to use ## RMS $PARSE and $SEARCH. subroutine fclosd( fd) integer fd call close(fd) return end #-t- fclosd 213 ascii 15-Jan-84 15:15:29 #-h- fgdrpr 1308 ascii 15-Jan-84 15:15:30 ## FGDrPr - (VMS) Get (next) filename `fil' from directory open on `fd'. ## This routine should probably be rewritten to use RMS ## $PARSE and $SEARCH directives. If you change it, be sure ## to fix `fopend' and `fclosd' as well... ## ## Note: `j' & `n' are expected to retain their values between calls... integer function fgdrpr( fd, fil) character fil(ARB) character buf(MAXLINE) integer fd integer count, fdb, i, j, junk, len, n integer getfdb, gets, itoc, length # function(s) integer*4 vers logical*1 tmp(4), low, high equivalence (tmp(1),vers), (low,tmp(1)), (high,tmp(2)) data j /0/ data n /0/ data vers /0/ fdb = getfdb(fd) if( j >= n ) # Read next record and extract filename. { n = gets( fdb, buf, MAXLINE) if( n == ERR ) { fgdrpr = ERR fil(1) = EOS return } count = buf(4) # Byte count of directory entry record. j = 5 for( i = 1 ; i <= count ; i = i + 1 ) { fil(i) = buf(j) j = j + 1 } fil(i) = '.' i = i + 1 if( mod( j, 2) == 0 ) # Align on even byte boundary. j = j + 1 len = i # Save length of filename. } i = len low = buf(j) high = buf(j+1) j = j + 8 # Point to next version number. junk = itoc(vers, fil(i), 10) # Tack on the version number. i = length(fil) + 1 fil(i) = EOS call fold(fil) fgdrpr = OK return end #-t- fgdrpr 1308 ascii 15-Jan-84 15:15:30 #-h- flushq 158 ascii 15-Jan-84 15:15:30 ## Flushq - Flush `oq' to `ochn'. subroutine flushq( ochn) integer ochn include cledit oq(qp) = EOS call putlin( oq, ochn) qp = 1 oq(qp) = EOS return end #-t- flushq 158 ascii 15-Jan-84 15:15:30 #-h- fopend 308 ascii 15-Jan-84 15:15:30 ## FOpenD - (VMS) Open directory file `fil' for reading; return `fd'. ## Use this version until `fgdrpr' & co. are taught to ## use RMS $PARSE and $SEARCH. integer function fopend( fil, fd) character fil(ARB) filedes fd integer open # Function(s) fd = open( fil, READ) fopend = fd return end #-t- fopend 308 ascii 15-Jan-84 15:15:30 #-h- gthist 256 ascii 15-Jan-84 15:15:31 ### GtHist Get a line from the history file for `lnedit'. integer function gthist( lin, i) character lin(ARB) integer i, j integer edline # function(s) lin(i) = '@n' lin( i + 1 ) = EOS j = edline(lin) if( j < 1 ) j = 1 lin(j) = EOS return(j) end #-t- gthist 256 ascii 15-Jan-84 15:15:31 #-h- insstr 248 ascii 15-Jan-84 15:15:31 ## InsStr - Insert string `s1' at position `i' of string `s2'. subroutine insstr( s1, s2, i) character s1(ARB), s2(ARB), t(MAXLINE) integer i, j call scopy( s2, i, t, 1) j = i call stcopy( s1, 1, s2, j) call stcopy( t, 1, s2, j) return end #-t- insstr 248 ascii 15-Jan-84 15:15:31 #-h- ledit 10256 ascii 15-Jan-84 15:15:32 ## LEdit - perform character editing on `lin'. character function ledit( pstr, lin, cur, ichn, ochn) include cledit integer cur, ichn, i, j, n, ochn, status integer addstr, index, ll2pl, length, max, min integer savcur, scn4ch, scnbbw, scnblw, scnebw, scnelw, type character c, lin(ARB), pstr(ARB), savlin(MAXLINE) character ctrlr(5), delstr(4), finstr(3) data ctrlr /'^', 'R', CR, LF, EOS/ data delstr /'d', ' ', EOS, EOS/ # Default `delete' command. data finstr /'f', ' ', EOS/ # Default `find' command. character ngetch, ngtnum hastab = NO #!!! Make this a switch call leinit( pstr, lin, cur, ochn) call strcpy( nl, savlin) savcur = nc call saveln( nl, nc) call updlin( ochn) repeat { n = 0 c = ngtnum(n, ichn) # Get num. prefix (if any) & next char. switch(c) # Dispatch on character { case 'u': # Restore line before last change. { call strcpy( undlin, nl) nc = undcur call saveln( ol, oc) } case 'U': # Restore line to state at entry. { call strcpy( savlin, nl) nc = savcur call saveln( ol, oc) } case RETYPELINE: # Redisplay prompt and line. { if( ol(oc) != EOS ) call putchq( ol(oc), ochn) call putstf( ctrlr, ochn) ol(1) = EOS oc = 1 call putstf( pstr, ochn) } case ' ': # Move -> chars. { if( nc + n > length(ol) + 1 ) n = length(ol) - nc + 1 nc = nc + n } case BACKSPACE, 'h': # Move <- chars. { if( n >= nc ) n = nc - 1 nc = nc - n } case '%', '0': # Move to beginning of line. nc = 1 case '$': # Move to end of line nc = length(ol) # Move -> words. case 'w': nc = scnblw( ol, oc, n) case 'W': nc = scnbbw( ol, oc, n) case 'e': nc = scnelw( ol, oc, n) case 'E': nc = scnebw( ol, oc, n) case 'f': # Move thru th instance of char. { finstr(1) = c c = ngetch( c, ichn) if( (c >= ' ' | c == '@t') & ol(oc) != EOS ) { finstr(2) = c nc = scn4ch( ol, oc, c, n) } } case 't': # Move to th instance of char. { finstr(1) = c c = ngetch( c, ichn) if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 ) { finstr(2) = c nc = scn4ch( ol, oc+1, c, n) - 1 } } case 'F': # Move <- thru th instance of char. { finstr(1) = c c = ngetch( c, ichn) i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc ) { finstr(2) = c n = -n nc = scn4ch( ol, oc, c, n) n = -n } } case 'T': # Move <- to th instance of char. { finstr(1) = c c = ngetch( c, ichn) i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc - 1 ) { finstr(2) = c n = -n nc = scn4ch( ol, oc-2, c, n) + 1 n = -n } } case ';': # ReQueue last `find' command. call pbcmd( EOS, n, finstr) case ',': # ReQueue last `find' in reverse. { if( finstr(1) == 'f' ) finstr(1) = 'F' else if( finstr(1) == 'F' ) finstr(1) = 'f' else if( finstr(1) == 't' ) finstr(1) = 'T' else finstr(1) = 't' call pbcmd( EOS, n, finstr) } case 'd': # Delete text object(s). { call saveln( ol, oc) c = ngtnum( n, ichn) # Allow count to follow `d' cmd. switch(c) # Dispatch for DELETE command { case '$': # Delete from cursor thru EOL. nl(nc) = EOS # nc will be adjusted by `updlin'. case '%': # Delete from BOL thru cursor. { call scopy( ol, oc+1, nl, 1) nc = 1 } case 'd': # Delete entire line. { delstr(2) = c delstr(3) = EOS nl(1) = EOS nc = 1 } case ' ': # Delete -> chars. { delstr(2) = c delstr(3) = EOS if( oc + n > length(ol) + 1 ) n = length(ol) - oc + 1 call scopy( ol, oc+n, nl, oc) } case 'w', 'W', 'e', 'E': # Delete -> words. { delstr(2) = c delstr(3) = EOS if( c == 'w' ) i = scnblw( ol, oc, n) else if( c == 'W' ) i = scnbbw( ol, oc, n) else if( c == 'e' ) i = scnelw( ol, oc, n) else i = scnebw( ol, oc, n) if( ol(i) != EOS & ol(i+1) != EOS & ( c == 'e' | c == 'E' ) ) i = i + 1 if( i == oc & ol(i+1) == EOS ) # Rubout last char. i = i + 1 call scopy( ol, i, nl, nc) } case 'b', 'B': # Delete <- words. { delstr(2) = c delstr(3) = EOS n = -n if( c == 'b' ) nc = scnblw( ol, oc, n) else nc = scnbbw( ol, oc, n) n = -n if( nc == oc & (ol(oc) == EOS | ol(oc+1) == EOS) ) nl(nc) = EOS else call scopy( ol, oc, nl, nc) } case 'f': # Delete -> thru th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c if( (c >= ' ' | c == '@t') & ol(oc) != EOS ) { i = scn4ch( ol, oc, c, n) if( i > oc ) call scopy( ol, i+1, nl, oc) } } case 't': # Delete -> to th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c if( (c >= ' ' | c == '@t') & length(ol) > oc + 1 ) { i = scn4ch( ol, oc+1, c, n) if( i > oc + 1 ) call scopy( ol, i, nl, oc) } } case 'F': # Delete <- thru th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc ) { n = - n i = scn4ch( ol, oc, c, n) n = -n call scopy( ol, oc, nl, i) } } case 'T': # Delete <- to th instance of char. { delstr(2) = c c = ngetch( c, ichn) delstr(3) = c i = index( ol, c) if( (c >= ' ' | c == '@t') & i > 0 & i < oc - 1 & oc > 2 ) { n = -n nc = scn4ch( ol, oc-2, c, n) + 1 n = -n call scopy( ol, oc, nl, nc) } } default: # Illegal object specified to `Delete' cmd. call lerror( 0, ochn) } } case '.': # ReQueue last `delete' command. call pbcmd( EOS, n, delstr) case 'b', 'B': # Move cursor <- words. { n = -n if( c == 'b' ) nc = scnblw( ol, oc, n) else nc = scnbbw( ol, oc, n) n = -n } case 'r': # Replace character under cursor. { c = ngetch( c, ichn) call saveln( ol, oc) if( c >= ' ' | c == '@t' ) nl(nc) = c } case 'x': # Queue a `d ' command. call pbcmd( EOS, n, "d ") case 'X': # Delete <- chars. { call saveln( ol, oc) if( n >= oc ) n = oc - 1 call strcpy( nl, ol) nc = oc - n call scopy( ol, oc, nl, nc) } case 'D': # Queue a `d$' command call pbcmd( EOS, n, "d$") case 'A': # Queue a `$a' command call pbcmd( "$", n, "a") case 'I': # Queue a `%i' command call pbcmd( "%", n, "i") case 'C': # Queue a `c$' command. call pbcmd( EOS, n, "c$") case 'a': # Append text after cursor. { call saveln( ol, oc) if( ol(oc) != EOS ) { call putchf( ol(oc), ochn) oc = oc + 1 } call rawtxt( oc, oc, n, ichn, ochn) } case 'i': # Insert text before cursor. { call saveln( ol, oc) call rawtxt( oc, oc, n, ichn, ochn) } case 'R': # Replace (overwrite) text at cursor. { call saveln( ol, oc) call rawtxt( oc, 0, n, ichn, ochn) } case 's': # Substitute new text for next chars. { call saveln( ol, oc) i = min( oc+n-1, length(ol)) c = nl(i) nl(i) = '$' # Mark end of text to be replaced. call updlin( ochn) nl(i) = c n = 1 call rawtxt( oc, i+1, n, ichn, ochn) } case 'c': # Change text object { c = ngtnum( n, ichn) # Allow count to follow `c' cmd. call saveln( ol, oc) switch(c) # Dispatch for Change { case '$': # Change text from cursor thru EOL. { call rawtxt( oc, length(ol)+1, n, ichn, ochn) } case '%': # Change text from BOL thru cursor. { c = nl(oc) nl(oc) = '$' nc = 1 call updlin( ochn) nl(oc) = c call rawtxt( nc, oc+1, n, ichn, ochn) } # Change -> words. case 'w', 'W', 'e', 'E': { if( c == 'w' ) i = scnblw( ol, oc, n) else if( c == 'W' ) i = scnbbw( ol, oc, n) else if( c == 'e' ) i = scnelw( ol, oc, n) else i = scnebw( ol, oc, n) if( i > 1 & ol(i+1) != EOS & (c == 'w' | c == 'W') ) i = i - 1 c = nl(i) nl(i) = '$' call updlin( ochn) nl(i) = c call rawtxt( oc, i+1, n, ichn, ochn) } default: # Illegal object specified to `Change' cmd. call lerror( 0, ochn) } } case CR: # CARRIAGE_RETURN -> return to caller break case ENDOFFILE, EDITLINE: # Move cursor to EOL. { nc = length(nl) call updlin( ochn) if( c == EDITLINE ) # Force CARRIAGE_RETURN. c = CR break } default: call lerror( 0, ochn) } call updlin( ochn) # Refresh line. call strcpy( nl, ol) oc = nc } nl(nc+1) = EOS call strcpy( nl, lin) cur = nc ledit = c return end #-t- ledit 10256 ascii 15-Jan-84 15:15:32 #-h- leinit 686 ascii 15-Jan-84 15:15:33 ## LEInit - Initialize intra-line editing variables. subroutine leinit( pstr, lin, curpos, ochn) character pstr(ARB), lin(ARB) integer cur, curpos, len, ochn integer length, ll2pl, max include cledit len = max( length( lin), 1) for( cur = curpos ; cur > len ; cur = cur - 1 ) call putch( BACKSPACE, ochn) call settab( EOS, tabs) lc1 = 1 call stcopy( pstr, 1, fl, lc1) pc1 = lc1 - 1 pc1 = ll2pl( fl, lc1-1, npl, npc) + 1 call scopy( lin, 1, fl, lc1) nmaxpc = ll2pl( fl, cur+lc1-1, npl, npc) call strcpy( npl, opl) omaxpc = nmaxpc opc = npc call strcpy( lin, nl) call strcpy( nl, ol) call strcpy( nl, undlin) nc = cur oc = cur undcur = cur qp = 1 oq(qp) = EOS return end #-t- leinit 686 ascii 15-Jan-84 15:15:33 #-h- lerror 173 ascii 15-Jan-84 15:15:33 ## LError - Process errors for intra-line editor. subroutine lerror( errcod, ochn) integer errcod, ochn # For now, just ring bell... call putch( BELL, ochn) return end #-t- lerror 173 ascii 15-Jan-84 15:15:33 #-h- ll2pl 1015 ascii 15-Jan-84 15:15:34 ## LL2PL Convert logical line to physical line; compute cursor posn. ## Set `pc' to physical position corresponding to logical `lc'. ## Return the maximum physical column written. integer function ll2pl( ll, lc, pl, pc) character c, ll(ARB), pl(ARB) integer i, lc, maxpc, pc, savepc integer max, tabpos # Function(s). include cledit pc = 1 maxpc = 1 savepc = 1 for( i = 1 ; ll(i) != EOS ; i = i + 1 ) { c = ll(i) if( c >= ' ' & c < RUBOUT ) #!!! Warning: ASCII assumed !!! { pl(pc) = c pc = pc + 1 } else if( c == '@t' ) { repeat { pl(pc) = '@t' pc = pc + 1 } until( tabpos( pc, tabs) == YES ) } else # Misc. control char; reserve 2 columns. { pl(pc) = c pl(pc+1) = c pc = pc + 2 } maxpc = max( maxpc, pc) if( i == lc ) # Save this pc. savepc = pc } pl(maxpc) = EOS if( savepc > 1 ) pc = max( savepc-1, pc1) else pc = max( maxpc, pc1) maxpc = max( maxpc-1, pc1) # Point at last char. written. ll2pl = maxpc return end #-t- ll2pl 1015 ascii 15-Jan-84 15:15:34 #-h- lngest 253 ascii 15-Jan-84 15:15:34 ## lngest - Return length of the longest substring common to two strings. integer function lngest( s1, s2) integer i character s1(ARB), s2(ARB) for( i = 1 ; s1(i) == s2(i) & s1(i) != EOS & s2(i) != EOS ; i = i + 1 ) ; lngest = i - 1 return end #-t- lngest 253 ascii 15-Jan-84 15:15:34 #-h- mvcurq 930 ascii 15-Jan-84 15:15:34 ## MvCurQ - Queue chars to move cursor from `c1' to `c2'. integer function mvcurq( bcklin, fwdlin, c1, c2, ochn) character bcklin(ARB), fwdlin(ARB) integer c1, c2, i, ochn integer putchq # Function(s). include cledit if( c1 <= c2 ) # Move cursor right. { for( i = c1 ; i <= c2 ; ) { if( fwdlin(i) == EOS ) { i = i + putchq( ' ', ochn) break } i = i + putchq( fwdlin(i), ochn) } i = i + putchq( BACKSPACE, ochn) } else # Move cursor left. { if( c1 - c2 < c2 + 2 ) { for( i = c1 ; i > c2 ; i = i + putchq( BACKSPACE, ochn) ) ; } else { call putchq( CR, ochn) for( i = 1 ; i < pc1 ; i = i + 1 ) call putchq( fl(i), ochn) while( i <= c2 ) { if( fwdlin(i) == EOS ) { i = i + putchq( ' ', ochn) break } i = i + putchq( fwdlin(i), ochn) } i = i + putchq( BACKSPACE, ochn) } } mvcurq = i return end #-t- mvcurq 930 ascii 15-Jan-84 15:15:34 #-h- ngtnum 520 ascii 15-Jan-84 15:15:35 ## NGtNum - Get numeric prefix (if any) for intra-line commands. character function ngtnum(n, ichn) character c, ngetch character numstr(12) integer i, n, ichn integer ctoi, type c = ngetch( c, ichn) if( c != '0' ) # Leading zeroes get passed back to caller. for( i = 1 ; type(c) == DIGIT ; i = i + 1 ) { numstr(i) = c c = ngetch( c, ichn) } if( i > 1 ) # Convert to integer. { numstr(i) = EOS i = 1 n = ctoi( numstr, i) } else if( n == 0 ) # Set default count. n = 1 ngtnum = c return end #-t- ngtnum 520 ascii 15-Jan-84 15:15:35 #-h- pbcmd 353 ascii 15-Jan-84 15:15:35 ## PBCmd - Put back a command for the intra-line editor. define(NUMSTRSIZE,11) subroutine pbcmd( prefix, num, cmdstr) character cmdstr(ARB), numstr(NUMSTRSIZE), prefix(ARB) integer junk, num integer itoc call pbstr( cmdstr) junk = itoc( num, numstr, NUMSTRSIZE) call pbstr( numstr) if( prefix(1) != EOS ) call pbstr( prefix) return end #-t- pbcmd 353 ascii 15-Jan-84 15:15:35 #-h- putchf 166 ascii 15-Jan-84 15:15:35 ## PutChF - Put character on `ochn' and flush queue. subroutine putchf( c, ochn) character c integer ochn call putchq( c, ochn) call flushq( ochn) return end #-t- putchf 166 ascii 15-Jan-84 15:15:35 #-h- putchq 1026 ascii 15-Jan-84 15:15:36 ## PutChQ - Put character into output queue. Flush queue if required. integer function putchq( c, ochn) character c integer cnt, i, ochn integer max, tabpos include cledit i = opc cnt = 1 if( c == '@t' ) { opl(opc) = '@t' for( opc = opc + 1 ; tabpos( opc, tabs) == NO ; opc = opc + 1 ) { opl(opc) = '@t' cnt = cnt + 1 } } else if( c == CR ) # CARRIAGE_RETURN opc = 1 else if( c == BACKSPACE ) opc = max( opc - 1, 1) else if( c >= ' ' ) { opl(opc) = c opc = opc + 1 } else if( c != '@n' ) { opl(opc) = c opl(opc+1) = c opc = opc + 2 cnt = 2 } if( qp + cnt >= MAXLINE ) # Queue overflow. Flush it. call flushq( ochn) if( c == '@t' & hastab == NO ) for( ; cnt > 0 ; cnt = cnt - 1 ) { oq(qp) = ' ' qp = qp + 1 } else if( c >= ' ' | c == BACKSPACE | c == CR | c == '@n' ) { oq(qp) = c qp = qp + 1 } else { oq(qp) = '^' oq(qp+1) = c + '@@' #!!! Warning: ASCII assumed !!! qp = qp + 2 } putchq = opc - i # Number of physical columns we've moved. return end #-t- putchq 1026 ascii 15-Jan-84 15:15:36 #-h- putstf 180 ascii 15-Jan-84 15:15:36 ## PutStF - Put string into output queue; flush queue. subroutine putstf( str, ochn) character str(ARB) integer i, ochn call putstq( str, ochn) call flushq( ochn) return end #-t- putstf 180 ascii 15-Jan-84 15:15:36 #-h- putstq 196 ascii 15-Jan-84 15:15:36 ## PutStQ - Put string into output queue. subroutine putstq( str, ochn) character str(ARB) integer i, ochn for( i = 1 ; str(i) != EOS ; i = i + 1 ) call putchq( str(i), ochn) return end #-t- putstq 196 ascii 15-Jan-84 15:15:36 #-h- rawio 586 ascii 15-Jan-84 15:15:37 ## rawio - determine if rawpmt can be used on unit integer function rawio( in, out, savmod) integer in, out, savmod integer create, stmode, isatty, gtmode string ttystr TTY_NAME if( out == EOF ) # need to open echo unit { out = create( ttystr, WRITE) if( out != ERR ) if( stmode(out, RARE) != RARE ) { call close(out) out = ERR } } rawio = NO if( isatty(in) == YES & out != ERR ) { savmod = gtmode(in) # save current mode if( stmode( in, RARE) == RARE ) # can do rare mode rawio = YES else savmod = stmode( in, savmod) } return end #-t- rawio 586 ascii 15-Jan-84 15:15:37 #-h- rawtxt 1731 ascii 15-Jan-84 15:15:37 ## Rawtxt - Get raw text for insert, append, change, and replace. subroutine rawtxt( fstcol, lstcol, n, ichn, ochn) integer end, i, ichn, fstcol, lstcol, n, ochn, olen, start integer length, max, whites # Function(s). character c, tail(MAXLINE) character getch include cledit start = fstcol end = lstcol olen = length(ol) if( end != 0 ) call scopy( ol, end, tail, 1) # Save rest of line. else call strcpy( ol, tail) i = start for( c = getch( c, ichn) ; c != ENDOFFILE & c != ESC ; c = getch( c, ichn) ) { if( c == EDITLINE ) { call putbak( EDITLINE) break } if( c == CR ) # CARRIAGE_RETURN { call putbak( CR) break } if( c == RUBOUT | c == BACKSPACE ) { if( i > start ) { i = i - 1 call bckupc( ochn, NO) call flushq( ochn) } } else if( c == WORDDELETE ) { for( ; i > start & whites(nl(i-1)) == YES ; i = i - 1 ) call bckupc( ochn, NO) for( ; i > start & whites(nl(i-1)) == NO ; i = i - 1 ) call bckupc( ochn, YES) call flushq( ochn) } else if( c >= ' ' | c == '@t' ) { nl(i) = c ol(i) = c call putchf( c, ochn) i = i + 1 nl(i) = EOS } else call putch( BELL, ochn) } nl(i) = EOS if( i > olen ) ol(i) = EOS oc = i call scopy( nl, start, tmplin, 1) # Insert text times. if( (length(tmplin)*n + start) < MAXLINE ) # Everything fits. for( n = n - 1 ; n > 0 ; n = n - 1 ) call stcopy( tmplin, 1, nl, i) nc = max( i - 1, start) if( end != 0 ) # Not overwrite mode. call strcpy( tail, tmplin) else call scopy( tail, i, tmplin, 1) if( (length(tmplin) + i) < MAXLINE ) # Everything fits. call stcopy( tmplin, 1, nl, i) else call putc( BELL, ochn) nl(i) = EOS return end #-t- rawtxt 1731 ascii 15-Jan-84 15:15:37 #-h- recogf 482 ascii 15-Jan-84 15:15:38 ## recogf - Recognize longest unique filename substring matching %`str'. ## complete the string in `str'. integer function recogf(str) integer i, j integer ds, length character outstr(FILENAMESIZE), str(ARB) j = length(str) i = j if( i > 0 ) repeat { if( str(i) == '/' | str(i) == '\' ) break i = i - 1 } until( i == 0 ) if( ds( str, outstr) == NO ) { recogf = ERR return } else { call scopy( outstr, 1, str, i+1) recogf = OK } return end #-t- recogf 482 ascii 15-Jan-84 15:15:38 #-h- saveln 175 ascii 15-Jan-84 15:15:38 ## SaveLn - Save line state for `undo' subroutine saveln( lin, cur) character lin(ARB) integer cur include cledit call strcpy( lin, undlin) undcur = cur return end #-t- saveln 175 ascii 15-Jan-84 15:15:38 #-h- scn4ch 561 ascii 15-Jan-84 15:15:38 ## Scn4Ch - Scan for th occurence of char . Update . integer function scn4ch( lin, i, c, n) integer i, j, k, n integer index # function(s) character c, lin(ARB) if( n > 0 ) { for( j = i ; index( lin(j+1), c) > 0 & n > 0 ; n = n - 1 ) { if( lin(j) == c ) j = j + 1 for( ; lin(j) != c & lin(j) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { k = index( lin, c) for( j = i ; k < j & n < 0 ; n = n + 1 ) { if( lin(j) == c ) j = j - 1 for( ; lin(j) != c ; j = j - 1 ) ; } } scn4ch = j return end #-t- scn4ch 561 ascii 15-Jan-84 15:15:38 #-h- scnbbw 684 ascii 15-Jan-84 15:15:39 ## ScnBBW - Scan to beginning of th (big) word. Update . integer function scnbbw( lin, i, n) integer i, j, n integer whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { for( ; whites(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { for( j = i ; j > 1 & n < 0 ; n = n + 1 ) { if( whites(lin(j-1)) == YES ) # At beginning of word. j = j - 1 for( ; whites(lin(j)) == YES & j > 1 ; j = j - 1 ) ; for( ; j > 1 ; j = j - 1) if( whites( lin(j-1)) == YES ) break } } return(j) end #-t- scnbbw 684 ascii 15-Jan-84 15:15:39 #-h- scnbck 727 ascii 15-Jan-84 15:15:39 ## ScnBck - Scan backwards until a terminator or boundary is reached. ## Return the index of the last character scanned before terminator. ## Output string `rubstr' on `chn' as each char is scanned. integer function scnbck( str, col, rubstr, chn, trmara) integer i, chn, col integer index character rubstr(ARB), str(ARB), trmara(ARB) if( col > 1 ) { i = col - 1 # Point to last char entered. for( ; index( trmara, str(i)) == 0 & i > 1 ; i = i - 1 ) if( rubstr(1) != EOS ) call putlin( rubstr, chn) if( i == 1 & index( trmara, str(i)) == 0 ) { if( rubstr(1) != EOS ) call putlin( rubstr, chn) } else i = i + 1 # Point to next char to be entered. } else i = 1 scnbck = i return end #-t- scnbck 727 ascii 15-Jan-84 15:15:39 #-h- scnblw 1065 ascii 15-Jan-84 15:15:39 ## ScnBLW - Scan to beginning of th (little) word. Update . integer function scnblw( lin, i, n) integer i, j, n integer alphan, whites # function(s) character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( alphan(lin(j)) == YES ) for( ; alphan(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; else if( alphan(lin(j)) == NO & whites(lin(j)) == NO ) for( ; alphan(lin(j)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { for( j = i ; j > 1 & n < 0 ; n = n + 1 ) { for( j = j - 1 ; j > 1 ; j = j - 1 ) if( whites( lin(j)) == NO ) break if( j > 1 ) if( alphan( lin(j)) == YES ) for( ; j > 1 ; j = j - 1 ) if( alphan( lin(j-1)) == NO ) break if( j > 1 ) if( alphan( lin(j)) == NO ) for( ; alphan(lin(j-1)) == NO & whites(lin(j-1)) == NO ; j = j - 1 ) if( j <= 2 ) break } } return(j) end #-t- scnblw 1065 ascii 15-Jan-84 15:15:39 #-h- scnebw 550 ascii 15-Jan-84 15:15:40 #### WARNING! case where n<0 has not been implemented. ## ScnEBW - Scan to end of th (big) word. Update . integer function scnebw( lin, i, n) integer i, j, n integer whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( whites(lin(j+1)) == YES ) # At end of word. j = j + 1 for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; for( ; whites(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { j = i } scnebw = j return end #-t- scnebw 550 ascii 15-Jan-84 15:15:40 #-h- scnelw 763 ascii 15-Jan-84 15:15:40 #### WARNING! case where n<0 has not been implemented. ## ScnELW - Scan to end of th (little) word. Update . integer function scnelw( lin, i, n) integer i, j, n integer alphan, whites character lin(ARB) if( n > 0 ) { for( j = i ; lin(j+1) != EOS & n > 0 ; n = n - 1 ) { if( lin(j) != EOS & lin(j+1) != EOS ) j = j + 1 for( ; whites(lin(j)) == YES & lin(j+1) != EOS ; j = j + 1 ) ; if( alphan(lin(j)) == YES ) { if( alphan(lin(j+1)) == YES ) for( ; alphan(lin(j+1)) == YES ; j = j + 1 ) ; } else if( alphan(lin(j+1)) == NO & whites(lin(j+1)) == NO ) for( ; alphan(lin(j+1)) == NO & lin(j+1) != EOS ; j = j + 1 ) ; } } else if( n < 0 ) { j = i } scnelw = j return end #-t- scnelw 763 ascii 15-Jan-84 15:15:40 #-h- spawnd 410 ascii 15-Jan-84 15:15:41 ## SpawnD -- Spawn the directory lister with an argument string. subroutine spawnd(args) character args(ARB), image(FILENAMESIZE), pid(PIDSIZE) integer loccom, spawn integer junk, init string d "d" string spath "@e~usr/@e~bin/@e@n" string suffix IMAGE_SUFFIX data init /YES/ if( init == YES ) { init = NO junk = loccom( d, spath, suffix, image) } junk = spawn( image, args, pid, WAIT) return end #-t- spawnd 410 ascii 15-Jan-84 15:15:41 #-h- spnbck 661 ascii 15-Jan-84 15:15:41 ## SpnBck - Span backwards until a non-separator or boundry is reached. ## Return the index of the last character scanned before separator. ## Output string `rubstr' on `chn' as each char is scanned. integer function spnbck( str, col, rubstr, chn, separa) integer i, chn, col integer index character rubstr(ARB), str(ARB), separa(ARB) if( col > 1 ) { i = col - 1 # Point to last char entered. for( ; index( separa, str(i)) > 0 & i > 1 ; i = i - 1 ) if( rubstr(1) != EOS ) call putlin( rubstr, chn) if( i == 1 ) { if( rubstr(1) != EOS ) call putlin( rubstr, chn) } else i = i + 1 } else i = 1 spnbck = i return end #-t- spnbck 661 ascii 15-Jan-84 15:15:41 #-h- updlin 1197 ascii 15-Jan-84 15:15:41 ## UpdLin - Update line on screen. subroutine updlin( ochn) integer ochn integer i, j, k integer d2eol, index, length, ll2pl, max, min, mvcurq, putchq # Function(s). include cledit nc = max( min( nc, length(nl) ), 1) # Make sure 1 <= nc <= length(nl). call scopy( ol, 1, fl, lc1) omaxpc = ll2pl( fl, oc+lc1-1, opl, opc) call scopy( nl, 1, fl, lc1) nmaxpc = ll2pl( fl, nc+lc1-1, npl, npc) # Translate log. line to phy. line. for( i = pc1 ; opl(i) == npl(i) ; i = i + 1 ) # Find 1st difference. if( opl(i) == EOS | npl(i) == EOS ) break if( npl(i) != opl(i) ) # Line has changed. { i = mvcurq( opl, npl, opc, i, ochn) # Move cursor there. if( nmaxpc == omaxpc & index( ol, '@t') == 0 ) # Save some repainting. { for( j = nmaxpc ; j > i ; j = j - 1 ) if( opl(j) != npl(j) ) break } else j = nmaxpc for( k = i ; k <= j & npl(k) != EOS ; ) # Output new text. k = k + putchq( npl(k), ochn) if( nmaxpc < omaxpc ) # Delete to end-of-line. k = k + d2eol( ochn) npc = mvcurq( npl, npl, k, npc, ochn) # Move cursor to desired position. } else # Just move cursor. npc = mvcurq( npl, npl, opc, npc, ochn) call flushq( ochn) return end #-t- updlin 1197 ascii 15-Jan-84 15:15:41 #-h- whites 168 ascii 15-Jan-84 15:15:42 ## WhiteS - Return yes if char is `whitespace' ('@t' | ' '). integer function whites( c) character c if( c == '@t' | c == ' ' ) return(YES) else return(NO) end #-t- whites 168 ascii 15-Jan-84 15:15:42 #-h- ngetch 339 ascii 15-Jan-84 15:15:42 # ngetch - get a (possibly pushed back) character character function ngetch(c, fd) character getch character c integer fd include clpb external pbinit if (pbp > 0) { c = pbbuf(pbp) pbp = pbp - 1 } else if (fd == ERR) c = EOF else c = getch(c, fd) ngetch = c return end #-t- ngetch 339 ascii 15-Jan-84 15:15:42 #-h- pbinit 50 ascii 15-Jan-84 15:15:42 block data pbinit include clpb data pbp/0/ end #-t- pbinit 50 ascii 15-Jan-84 15:15:42 #-h- pbstr 342 ascii 15-Jan-84 15:15:43 # pbstr - push string back onto input subroutine pbstr(in) character in(ARB) integer length integer i include clpb for (i = length(in); i > 0; i = i - 1) { pbp = pbp + 1 if (pbp > PB_SIZE) call error("pbstr - too many characters pushed back") pbbuf(pbp) = in(i) } return end #-t- pbstr 342 ascii 15-Jan-84 15:15:43 #-h- putbak 235 ascii 15-Jan-84 15:15:43 # putbak - push character back onto input subroutine putbak(c) character c include clpb pbp = pbp + 1 if (pbp > PB_SIZE) call error("putbak - too many characters pushed back") pbbuf(pbp) = c return end #-t- putbak 235 ascii 15-Jan-84 15:15:43 #-t- lnedit.r 43925 ascii 15-Jan-84 15:16:47 #-h- esh.man 16338 ascii 15-Jan-84 15:19:39 Esh (1) 5-Oct-81 Esh (1) NAME Esh - extended shell, with intraline editing and history SYNOPSIS esh [-cdnvx] [file [arguments]] DESCRIPTION `esh' is an extended version of `sh' which incorporates several features designed to make it easier to use. L I N E E D I T I N G o Both backspace (^H) and RUBOUT (RUB, DEL) may be used to delete the last character typed. o ^U may be used to undo the current line - i.e. delete it and re-prompt for the line. o ^R may be used to re-type the line. This is useful when working on a hard-copy terminal, since character deletes are done with backspaces. o ^W deletes the last word, where words are defined as strings of non-blanks. o ^D causes the current working directory to be listed on the terminal, after which the line is re-displayed and you may continue input on the current line. This is useful when you get part way through a command, and then realize that the critical file name has slipped from recent memory. o ^F (or ESC) causes file recognition to be performed on the current pathname. If the filename can be extended unambiguously, it will be; otherwise, a list of files matching the current pattern are displayed, the line re-displayed, and you may continue input on the line. o ^A causes the previous command line to be retrieved and the cursor to be positioned at the end. This is useful for adding stages to pipelines, for example. ^A may also be used in conjunction with the history mechanism to append to previous commands. o ^E causes the intraline editor to be entered. If the cursor is at the beginning of a line the previous line is retrieved; otherwise the current line is edited. The editing commands are discussed below in the section on intraline editing. -1- Esh (1) 5-Oct-81 Esh (1) H I S T O R Y M E C H A N I S M A history of the commands input to `esh' are maintained for each session. You may invoke special history manipulating functions by starting a command line with an exclamation mark (! - also known as a BANG) in column 1. If is is necessary to send a line starting with a BANG to the shell, lines starting with "@!" have the "@" stripped off, and the remainder of the line is given to the shell. Lines starting with BANG enable you to communicate with a miniature version of the editor `ed'. At any time, the last 25 commands are available for recall and manipulation. The current line concept of `ed' is supported, although the current line is ALWAYS the last command in the history. Legal history commands are: 1. history display !h[istory] [n][l] This is the equivalent of a browse command in `ed'. !h will display the last screenful of commands, along with their line numbers. The screensize, which defaults to 22 lines, may be changed by specifying a BLANK and a number following the !h[istory] string (!h 10, for example). The new screensize is remembered and used in all !h commands as the default screensize. Specifying a screensize larger than 25 has the effect of setting the size to 25. The optional trailing `l' (list) will cause control characters in the commands to be displayed as `^', where is the character one needs to type in conjunction with the CTRL key to generate the control character. !b[rowse] [n][l] This command is a synonym for history. It is included to increase the similiarity of function with the editor. 2. history recall ![line_number][;line_number]... This command permits the recall of a command from the history for re-execution. The command so recalled is displayed and then passed on to the shell for execution. This command is then entered at the bottom of the history. -2- Esh (1) 5-Oct-81 Esh (1) Valid line_numbers are the same as those for the editor. For example, a line_number may be the number listed next to the command in the history display, a pattern of the form "\pattern[\]", which indicates a backward search in the 25 line history window, or a pattern of the form "/pattern[/]", indicating a search forward, wrapping to the start of the 25 line window. The trailing '\' or '/' are optional when specifying a single pattern. The semi-colon syntax is the same as that in `ed', indicating that the search for the second pattern is to start at the line where the first pattern was found. If the pattern specified was illegal, or a line matching the pattern could not be found, or an invalid line_number was specified, a comment is displayed # invalid line number and you are prompted for more input. The history is not modified in this case. All sequences of patterns resolve into a single line number. It is not possible to request a range of lines from the history. It should be noted that the line_numbering is completely regular with `ed'. In particular, "!" followed by nothing maps into a fetch of the current line (last command typed). See the writeup on `ed' for more details on the specification of line_numbers. 3. history recall and modification ![line_number]s/pat/repl[/[g]] Upon successfully recalling a command from the history, it may be modified before it is passed on to `esh' for execution. This is performed with the 's' command, which is exactly the same as that for `ed'. The delimiters for `pat' and `repl' may be any character, the remembered pattern feature is available, and the trailing delimiter after the replacement pattern is optional. The optional trailing `g' indicates substitution for all occurrences of 'pat' in the line. See the `ed' manual entry for more information on the substitute command. If the substitution fails for any reason, a comment is displayed -3- Esh (1) 5-Oct-81 Esh (1) # illegal substitution and you are prompted for more input. The history is not modified in this case. 4. history archiving !w[rite] [>[>]]file This command permits you to archive (save) the entire transcript of activity to a file. It also passes an EOF to `esh', which causes `esh' to terminate execution. The commands !w file !w >file both cause `file' to be overwritten with the transcript, while >>file causes the transcript to be appended to `file'. It should be noted that the !w command causes ALL of the input given to `esh' in this session to be saved, not just the current 25 line window. It also passes an EOF to `esh', which will terminate execution. 5. history deletion !q[uit] ^Z These commands cause an EOF to be sent to `esh' and the deletion of the log of activity. Lines consisting solely of a carriage return are NOT logged in the history. If you need to perform several edits on a command before having it executed, you can exploit the fact that lines beginning with a sharp (#) are comments to the shell. For example: !\%ed\s/%/#/ !s/pat1/repl1/ . . . . . . !s/patn/repln/ !s/%#// -4- Esh (1) 5-Oct-81 Esh (1) All of the intermediate comment lines will be placed in the history, displacing other lines from the window which may possibly be needed. Of course, it may be simpler in such cases to just enter the command by hand. I N T R A L I N E E D I T I N G The intraline editing functions are a subset of those available in the "VI" screen editor from Berkeley. You are referred to the VI documentation for a tutorial introduction. The intraline editing "mode" is entered via ^E. Exactly what happens when the ^E is typed depends on what precedes it on the command line. If the ^E is the first character on a line, the previous command is retrieved and the cursor is positioned at the beginning of the line. If the line is a history reference (i.e. begins with a "!"), the referenced line is retrieved and the cursor is positioned at the beginning of the line. If the line is anything else, the cursor is positioned at the end of the line. Once in the intraline editor the following commands are allowed: Notes: `[n]' indicates an optional integer count input is terminated with ^Z or ESC MOVE cursor: ------------ [n]SPACE -> positions [n]BS <- positions [n]h <- positions % <- to beginning of line (BOL) $ -> to end of line (EOL) [n]w -> (non-alphanumeric) words [n]W -> (non-blank) words [n]b <- (non-alphanumeric) words [n]B <- (non-blank) words [n]e -> to end of th (non-alphanumeric) word [n]E -> to end of th (non-blank) word [n]f -> thru th occurrence of char [n]t -> to th occurrence of char [n]F <- thru th occurrence of char [n]T <- to th occurrence of char [n]; Repeat last `f', `t', `F', or `T' [n], Repeat last `f', `t', `F', or `T' in reverse -5- Esh (1) 5-Oct-81 Esh (1) INSERT or APPEND : ------------------------ [n]i Insert text before cursor [n]I Insert text before beginning of line [n]a Append text after cursor [n]A Append text after end of line REPLACE or SUBSTITUTE for character(s): ---------------------------------------------- R Replace (overlay) text on screen with r Replace current character with [n]s Substitute characters with CHANGE to : ------------------- [n]cw next (non-alphanumeric) words to [n]cW next (non-blank) words to [n]ce thru end of th (non-alphanumeric) word to [n]cE thru end of th (non-blank) word to c% text from BOL thru cursor to c$ text from cursor thru EOL to C Synonym for `c$' DELETE (s): ------------------------ [n]x characters, starting at cursor [n]dSPACE characters, starting at cursor [n]X previous characters [n]dw next (non-alphanumeric) words [n]dW next (non-blank) words [n]db previous (non-alphanumeric) words [n]dB previous (non-blank) words [n]df thru next th occurrence of char [n]dt to next th occurrence of char [n]dF thru prev th occurrence of char [n]dT to prev th occurrence of char dd entire line d% from beginning of line to cursor, inclusive d$ from cursor to end of line, inclusive D Synonym for `d$' -6- Esh (1) 5-Oct-81 Esh (1) [n]. Repeat previous `delete' command UNDO action of previous command(s): ----------------------------------- u Undo the last change to the line U Undo ALL commands; restore line to original state EXIT intra-line editor: ----------------------- ^Z Move cursor to EOL and exit intra-line edit ^E Move cursor to EOL and force RETURN RETURN Delete after cursor to EOL and execute command line The three methods of exiting the intraline editing mode are worthy of special mention. In particular you will usually exit with ^E rather than RETURN or ^Z, since the RETURN will chop off everything to the right of the cursor and ^Z will merely return to the line-gathering routine which invoked the intraline editor. Note that a ^E^E sequence may be used to repeat the previous command line. FILES SEE ALSO sh - command line interpreter DIAGNOSTICS # invalid line number # invalid substitution AUTHORS Editing features: Dave Martin History mechanism: Joe Sventek BUGS/DEFICIENCIES -7- #-t- esh.man 16338 ascii 15-Jan-84 15:19:39 #-t- lnedit.all 62860 ascii 15-Jan-84 15:23:41 #-h- lib.m 10873 ascii 15-Jan-84 15:23:53 #-h- chcopy.mar 442 ascii 15-Jan-84 14:37:10 .title chcopy ; ; this routine implements the following interface ; ; call chcopy(c, out, j) ; ; after the copy, j is incremented and out is EOS-terminated ; c=4 out=8 j=12 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry chcopy ^m<> addl3 out(ap),@j(ap),r0 ; address of out(j) decl r0 ; movb @c(ap),(r0)+ ; copy character clrb (r0) ; write EOS into out(j+1) incl @j(ap) ; increment j ret .end #-t- chcopy.mar 442 ascii 15-Jan-84 14:37:10 #-h- clower.mar 365 ascii 15-Jan-84 14:37:10 .title clower ;+ ; character function clower(x) ;- x=4 biga=65 bigz=90 leta=97 letz=122 dif=leta-biga .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry clower ^m<> movzbl @x(ap),r0 ; fetch character cmpb r0,#biga ; >= A? blss 10$ ; NO cmpb r0,#bigz ; <= Z? bgtr 10$ ; NO addl2 #dif,r0 ; make it lower case 10$: ret .end #-t- clower.mar 365 ascii 15-Jan-84 14:37:10 #-h- concat.mar 589 ascii 15-Jan-84 14:37:10 .title concat ; ; this routine implements the following interface ; ; call concat(a, b, c) ; ; a and b are EOS-terminated strings. a and b will be concatenated ; into c. a and c may be the same variable. ; a=4 b=8 c=12 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry concat ^m<> movl a(ap),r0 ; source address movl c(ap),r1 ; destination address 10$: movb (r0)+,(r1)+ ; copy character bneq 10$ ; until EOS tstb -(r1) ; went one too far movl b(ap),r0 ; source address 20$: movb (r0)+,(r1)+ ; copy character bneq 20$ ; until EOS ret .end #-t- concat.mar 589 ascii 15-Jan-84 14:37:10 #-h- cupper.mar 365 ascii 15-Jan-84 14:37:11 .title cupper ;+ ; character function cupper(x) ;- x=4 biga=65 bigz=90 leta=97 letz=122 dif=leta-biga .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry cupper ^m<> movzbl @x(ap),r0 ; fetch character cmpb r0,#leta ; >= a? blss 10$ ; NO cmpb r0,#letz ; <= z? bgtr 10$ ; NO subl2 #dif,r0 ; make it upper case 10$: ret .end #-t- cupper.mar 365 ascii 15-Jan-84 14:37:11 #-h- equal.mar 576 ascii 15-Jan-84 14:37:11 .title equal ; ; this routine implements the following interface ; ; status = equal(a, b) ; ; a and b are EOS-terminated strings ; if equal, return(YES[1]) else return(NO[0]) ; a=4 b=8 yes=1 no=0 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry equal ^m movl a(ap),r1 ; address of a(1) movl b(ap),r2 ; address of b(1) movl #no,r0 ; assume not equal 10$: cmpb (r1)+,(r2) ; compare next character bneq 20$ ; not equal, return tstb (r2)+ ; is this EOS (0)? bneq 10$ ; no, try again movl #yes,r0 ; return(YES) 20$: ret .end #-t- equal.mar 576 ascii 15-Jan-84 14:37:11 #-h- fold.mar 625 ascii 15-Jan-84 14:37:11 .title fold ;+ ; subroutine fold(buf) ; ; character buf(ARB) ; ; any characters found in the range A-Z are folded to the corresponding ; lower case character ;- buf=4 biga=65 bigz=90 leta=97 letz=122 dif=leta-biga .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry fold ^m<> movl buf(ap),r1 ; address of buf(1) 10$: movzbl (r1),r0 ; fetch next character beql 20$ ; if == 0, done cmpb r0,#biga ; >= A? blss 30$ ; NO cmpb r0,#bigz ; <= Z? bgtr 30$ ; NO addl2 #dif,r0 ; make lower case 30$: movb r0,(r1)+ ; copy character back into string brb 10$ ; try again 20$: ret .end #-t- fold.mar 625 ascii 15-Jan-84 14:37:11 #-h- gtftok.mar 813 ascii 15-Jan-84 14:37:12 .title gtftok ;+ ; integer function gtftok(buf, i, token) ;- buf=4 i=8 token=12 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry gtftok ^m movl buf(ap),r1 ; address of buf(1) movl i(ap),r3 ; address of i decl (r3) ; i = i - 1 addl2 (r3),r1 ; address of buf(i) movl token(ap),r2 ; address of token(1) clrl r0 ; initialize return count incl (r3) ; i = i + 1 cmpb (r1),#^a"/" ; buf(i) == SLASH? bneq 10$ ; NO incl (r3) ; i = i + 1 incl r1 ; address of buf(i) 10$: movb (r1)+,(r2) ; copy character beql 30$ ; if == 0, done cmpb (r2),#^a"/" ; SLASH? beql 20$ ; YES incl r0 ; increment count incl (r3) ; i = i + 1 cmpb (r2)+,#^a"\" ; BACKSLASH? bneq 10$ ; NO, do next character 20$: clrb (r2) ; terminate with EOS 30$: ret .end #-t- gtftok.mar 813 ascii 15-Jan-84 14:37:12 #-h- impath.mar 802 ascii 15-Jan-84 14:37:12 .title impath ;+ ; subroutine impath(buf) ;- .psect st_impath_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long spath: .asciz "~usr/" .asciz "~bin/" .byte 10,0 spathl=.-spath buf=4 path=5 ; same as PATH in ~bin/symbols dtype: .long path ; desire tooldr in pathname format .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry impath ^m movl buf(ap),r2 ; destination address clrb (r2)+ ; EOS => search cwd first pushal dtype ; desire pathname format pushl r2 ; buffer for tooldr calls #2,tooldr ; fetch tools directory info 20$: tstb (r2)+ ; at end of tools directory yet? bneq 20$ ; NO moval spath,r1 ; source array address movl #spathl,r0 ; length of array 10$: movb (r1)+,(r2)+ ; copy character sobgtr r0,10$ ; do again ret .end #-t- impath.mar 802 ascii 15-Jan-84 14:37:12 #-h- index.mar 676 ascii 15-Jan-84 14:37:12 .title indexx ; ; this routine provides the following interface ; ; i = indexx(buf, char) ; ; where buf is an EOS-terminated string ; if found, return(i) such that buf(i) == char ; else return(0) ; buf=4 char=8 eos=0 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry indexx ^m movl buf(ap),r1 ; address of buf(1) movzbl @char(ap),r2 ; character to find clrl r0 ; initialize character position 10$: incl r0 ; increment to current character pos tstb (r1) ; see if at EOS beql 20$ ; YES cmpb (r1)+,r2 ; is this the character? beql 30$ ; YES, return brb 10$ ; try again 20$: clrl r0 ; character not found 30$: ret .end #-t- index.mar 676 ascii 15-Jan-84 14:37:12 #-h- length.mar 435 ascii 15-Jan-84 14:37:13 .title length ; ; function to return the length of an EOS-terminated string ; ; n = length(str) ; ; where str is the address of the string ; eos=0 str=4 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry length ^m<> movl str(ap),r1 ; address of string clrl r0 ; initialize length 10$: incl r0 ; increment length tstb (r1)+ ; see if at EOS bneq 10$ ; NO decl r0 ; went one too far ret .end #-t- length.mar 435 ascii 15-Jan-84 14:37:13 #-h- scopy.mar 433 ascii 15-Jan-84 14:37:13 .title scopy ; ; this routine implements the following interface ; ; call scopy(in, i, out, j) ; ; where in is an EOS-terminated string ; in=4 i=8 out=12 j=16 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry scopy ^m<> addl3 in(ap),@i(ap),r0 decl r0 ; address of in(i) addl3 out(ap),@j(ap),r1 decl r1 ; address of out(j) 10$: movb (r0)+,(r1)+ ; copy character bneq 10$ ; go again ret .end #-t- scopy.mar 433 ascii 15-Jan-84 14:37:13 #-h- stcopy.mar 559 ascii 15-Jan-84 14:37:13 .title stcopy ; ; this routine provides the following interface ; ; call stcopy(in, i, out, j) ; ; in is an EOS-terminated string, j is incremented ; out is EOS-terminated ; in=4 i=8 out=12 j=16 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry stcopy ^m addl3 in(ap),@i(ap),r0 decl r0 ; address of in(i) movl j(ap),r2 ; address of j decl (r2) ; back j up one addl3 out(ap),(r2),r1 ; address of out(j) 10$: incl (r2) ; increment j movb (r0)+,(r1)+ ; copy character bneq 10$ ; if != 0, do next one ret .end #-t- stcopy.mar 559 ascii 15-Jan-84 14:37:13 #-h- strcmp.mar 565 ascii 15-Jan-84 14:37:14 .title strcmp ;+ ; integer function strcmp(str1, str2) ;- str1=4 str2=8 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry strcmp ^m movl str1(ap),r1 ; start of str1 movl str2(ap),r2 ; start of str2 clrl r0 ; assume equal 10$: cmpb (r1),(r2) ; characters equal? bneq 20$ ; NO tstb (r1)+ ; at EOS? beql 100$ ; YES incl r2 ; bump address to next character brb 10$ 20$: movl #-1,r0 ; assume str1 < str2 cmpb (r1),(r2) ; compare characters blss 100$ ; str1 < str2 movl #1,r0 ; return(+1) 100$: ret .end #-t- strcmp.mar 565 ascii 15-Jan-84 14:37:14 #-h- strcpy.mar 309 ascii 15-Jan-84 14:37:14 .title strcpy ;+ ; subroutine strcpy(in, out) ;- in=4 out=8 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry strcpy ^m<> movl in(ap),r0 ; source address movl out(ap),r1 ; destination address 10$: movb (r0)+,(r1)+ ; copy character bneq 10$ ; if not 0, do again ret .end #-t- strcpy.mar 309 ascii 15-Jan-84 14:37:14 #-h- type.mar 546 ascii 15-Jan-84 14:37:14 .title type ;+ ; integer function type(c) ;- c=4 letter=1 digit=2 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry type ^m<> movb @c(ap),r0 ; character being typed cmpb r0,#^a"0" ; digit? blss 20$ ; NO cmpb r0,#^a"9" ; digit? bgtr 10$ ; NO movl #digit,r0 ; return(DIGIT) brb 30$ 10$: bicb #^x20,r0 ; make upper case cmpb #^a"A",r0 ; letter? bgtr 20$ ; NO cmpb #^a"Z",r0 ; letter? blss 20$ ; NO movl #letter,r0 ; return(LETTER) brb 30$ 20$: movzbl @c(ap),r0 ; return(c) 30$: ret .end #-t- type.mar 546 ascii 15-Jan-84 14:37:14 #-h- upper.mar 629 ascii 15-Jan-84 14:37:15 .title upper ;+ ; subroutine upper(buf) ; ; character buf(ARB) ; ; any characters found in the range A-Z are changed to the corresponding ; upper case character ;- buf=4 biga=65 bigz=90 leta=97 letz=122 dif=leta-biga .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry upper ^m<> movl buf(ap),r1 ; address of buf(1) 10$: movzbl (r1),r0 ; fetch next character beql 20$ ; if == 0, done cmpb r0,#leta ; >= a? blss 30$ ; NO cmpb r0,#letz ; <= z? bgtr 30$ ; NO subl2 #dif,r0 ; make upper case 30$: movb r0,(r1)+ ; copy character back into string brb 10$ ; try again 20$: ret .end #-t- upper.mar 629 ascii 15-Jan-84 14:37:15 #-t- lib.m 10873 ascii 15-Jan-84 15:23:53 #-t- lib.ar 181587 ascii 15-Jan-84 15:25:46 #-h- prim.m 42428 ascii 15-Jan-84 15:26:06 #-h- cctype.mar 910 ascii 15-Jan-84 14:45:08 .title cctype ; ; this routine implements the following interface ; ; crg_ctrl = cctype(fdb) ; ; where fdb is the integer RAB address returned by the getfdb call ; ; the value returned is ; ; none(0) if no implied carriage control for records ; fort(1) if fortran type carriage control ; list(2) if list carriage control ; prn(3) if print carriage control ; rab=4 none=0 fort=1 list=2 prn=3 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry cctype ^m<> movl @rab(ap),r0 ; get RAB address movl rab$l_fab(r0),r0 ; have FAB address movzbl fab$b_rat(r0),r1 ; have recort attribute byte bbs #fab$v_cr,r1,20$ ; list carriage control bbs #fab$v_ftn,r1,10$ ; fortran carriage control bbs #fab$v_prn,r1,30$ ; print carriage control movl #none,r0 ; NONE brb 40$ 10$: movl #fort,r0 ; FORT brb 40$ 20$: movl #list,r0 ; LIST brb 40$ 30$: movl #prn,r0 ; PRINT 40$: ret .end #-t- cctype.mar 910 ascii 15-Jan-84 14:45:08 #-h- chmod.mar 1186 ascii 15-Jan-84 14:45:09 .title ChMod ; ; Change the mode (protection codes) of a file. ; ; SYNOPSIS ; ; stat = chmod( name, mode) ; ; character name - zero byte terminated string with file name ; integer mode - desired mode (see RMS manual for format) ; ; integer stat - OK | ERR ; ; local definitions ; ok=0 ; software tools OK return err=-3 ; software tools ERR return name=4 ; ap offset to name of file mode=8 ; ; local data ; .psect st_chmod_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long xpro: $xabpro mfab: $fab fna=buf,- fop=cif,- xab=xpro ; buf: .blkb 120 ; ; entry point ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry chmod ^m<> pushal buf pushl name(ap) calls #2,mklocl ; convert to DEC format name pushal buf calls #1,upper ; crunch it to upper case pushal buf calls #1,length ; calculate length of string movl r0,r1 ; move length to safe place $fab_store fab=mfab,fns=r1 ; store length of string $create fab=mfab ; open file blbc r0,error ; low bit clear indicates error mcomw @mode(ap),xab$w_pro+xpro ; set protection $close fab=mfab blbc r0,error ; low bit clear indicates error movl #ok,r0 ret error: movl #err,r0 ret .end #-t- chmod.mar 1186 ascii 15-Jan-84 14:45:09 #-h- chown.mar 1231 ascii 15-Jan-84 14:45:09 .title ChOwn ; ; Change the owner and group of a file. ; ; SYNOPSIS ; ; stat = chown( name, owner, group) ; ; character name - zero byte terminated string with file name ; integer owner - integer for owner number ; integer group - integer for group number ; ; integer stat - OK | ERR ; ; local definitions ; ok=0 ; software tools OK return err=-3 ; software tools ERR return name=4 ; ap offset to name of file owner=8 group=12 ; ; local data ; .psect st_chown_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long xpro: $xabpro mfab: $fab fna=buf,- fop=cif,- xab=xpro ; buf: .blkb 120 ; ; entry point ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry chown ^m<> pushal buf pushl name(ap) calls #2,mklocl ; convert to DEC format name pushal buf calls #1,upper ; crunch it to upper case pushal buf calls #1,length ; calculate length of string movl r0,r1 ; move length to safe place $fab_store fab=mfab,fns=r1 ; store length of string $create fab=mfab ; open file blbc r0,error ; low bit clear indicates error movw @group(ap),xab$w_grp+xpro ; set group number movw @owner(ap),xab$w_mbm+xpro ; set member number $close fab=mfab movl #ok,r0 ret error: movl #err,r0 ret .end #-t- chown.mar 1231 ascii 15-Jan-84 14:45:09 #-h- closef.mar 894 ascii 15-Jan-84 14:45:09 .title closef ; ; subroutine to close file opened with tools openf ; ; call sequence: call closef(rab) ; ; where rab is the integer descriptor returned by openf ; rab=4 ; offset from ap for rab address .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry closef ^m movl @rab(ap),r2 ; place rab address in r2 movl rab$l_fab(r2),r3 ; fab address in r3 blbc rab$l_ctx(r2),10$ ; lbc ==> do not truncate file bbs #1,rab$l_ctx(r2),10$ ; bit 1 set ==> put was done $find rab=r2 ; position to first record $truncate rab=r2 ; truncate file 10$: clrl rab$l_ctx(r2) ; clear context $disconnect rab=r2 ; disconnect record stream blbc r0,error ; low bit clear in r0 => error $close fab=r3 ; close file blbc r0,error ; again check for error pushl r2 ; place rab address on stack calls #1,putrab ; return rab to linked list ret error: ret .end #-t- closef.mar 894 ascii 15-Jan-84 14:45:09 #-h- crelogsup.mar 312 ascii 15-Jan-84 14:45:10 .title CreLogSup -- Create logical name in supervisor mode crelogsup:: start: .word ^m movl 4(ap),r2 movl 8(ap),r3 $cmexec_s routin=setvar ret setvar: .word 0 pushl #2 ;acmode pushl r3 ;eqlnam pushl r2 ;lognam pushl #2 ;tblflg, 0 system, 1 group, 2 process calls #4,g^sys$crelog ret .end #-t- crelogsup.mar 312 ascii 15-Jan-84 14:45:10 #-h- decnfo.mar 2226 ascii 15-Jan-84 14:45:10 .title decnfo ; ; ; subroutine to return information on a file for directory listings ; ; ; invocation: ; ; stat = decnfo(name, date, group, member, protection, eof, free, ftype) ; ; character name - zero byte terminated string with file name ; integer date(2) - quadword for date ; integer group - integer for group number ; integer member - integer for member number ; integer protect - integer to hold protection mask ; integer eof - block number containing eof ; integer free - first free byte of eof block ; integer ftype - file type (ASCII | BINARY) ; ; function return - OK | ERR ; ; ; local definitions ; ok=0 ; software tools OK return err=-3 ; software tools ERR return ascii=12 ; software tools ASCII binary=60 ; software tools BINARY name=4 ; ap offset to name of file date=8 ; ap offset to date quadword group=12 member=16 protection=20 eof=24 free=28 ftype=32 ; local data ; .psect st_decnfo_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long xdat: $xabdat nxt=xpro xpro: $xabpro nxt=xfhc xfhc: $xabfhc mfab: $fab fac=get,- fna=buf,- shr=,- xab=xdat buf: .blkb 120 ; ; entry point ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry decnfo ^m<> pushal buf pushl name(ap) calls #2,strcpy ; copy string into buf pushal buf calls #1,upper ; crunch it to upper case pushal buf calls #1,length ; calculate length of string movl r0,r1 ; move length to safe place $fab_store fab=mfab,fns=r1 ; store length of string $open fab=mfab ; open file to get info blbc r0,error ; low bit clear indicates error movq xab$q_rdt+xdat,@date(ap) ; return revision date bneq gotit movq xab$q_cdt+xdat,@date(ap) ; return creation date gotit: movzwl xab$w_grp+xpro,@group(ap) ; return group number movzwl xab$w_mbm+xpro,@member(ap) ; return member number movzwl xab$w_pro+xpro,@protection(ap) ; return protection movl xab$l_ebk+xfhc,@eof(ap) ; return eof block movzwl xab$w_ffb+xfhc,@free(ap) ; return free byte movl #ascii,@ftype(ap) ; assume ASCII file bitb #fab$c_var,mfab+fab$b_rfm ; see if variable length recs bneq ischar ; if !=, is ASCII file movl #binary,@ftype(ap) ischar: $close fab=mfab movl #ok,r0 ret error: movl #err,r0 ret .end #-t- decnfo.mar 2226 ascii 15-Jan-84 14:45:10 #-h- devtyp.mar 540 ascii 15-Jan-84 14:45:10 .title devtyp ; ; function to return the the device type for the particular unit ; ; calling sequence type = devtyp(rab) ; ; where rab is the integer descriptor returned by openf ; ttydevice=1 mbxdevice=2 otherdevice=3 rab=4 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry devtyp ^m<> movl @rab(ap),r1 movl rab$l_fab(r1),r0 movl fab$l_dev(r0),r1 bbc #dev$v_trm,r1,10$ movl #ttydevice,r0 brb getout 10$: bbc #dev$v_mbx,r1,20$ movl #mbxdevice,r0 brb getout 20$: movl #otherdevice,r0 getout: ret .end #-t- devtyp.mar 540 ascii 15-Jan-84 14:45:10 #-h- directory.mar 2687 ascii 15-Jan-84 14:45:11 .title directory ok=0 eof=-1 err=-3 ; ; linked list of FAB's for directory routines ; next_fab=-4 ; offset from FAB to pointer to next FAB fab_10=0 ; end of list exp_str_size=100 ; size of expanded string ; ; free list listhead ; .psect st_directory_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long free_fab: .address fab_0 .address fab_1 fab_0: $fab nam=nam_0 nam_0: $nam esa=esb_0,ess=exp_str_size esb_0: .blkb exp_str_size .address fab_2 fab_1: $fab nam=nam_1 nam_1: $nam esa=esb_1,ess=exp_str_size esb_1: .blkb exp_str_size .address fab_3 fab_2: $fab nam=nam_2 nam_2: $nam esa=esb_2,ess=exp_str_size esb_2: .blkb exp_str_size .address fab_4 fab_3: $fab nam=nam_3 nam_3: $nam esa=esb_3,ess=exp_str_size esb_3: .blkb exp_str_size .address fab_5 fab_4: $fab nam=nam_4 nam_4: $nam esa=esb_4,ess=exp_str_size esb_4: .blkb exp_str_size .address fab_6 fab_5: $fab nam=nam_5 nam_5: $nam esa=esb_5,ess=exp_str_size esb_5: .blkb exp_str_size .address fab_7 fab_6: $fab nam=nam_6 nam_6: $nam esa=esb_6,ess=exp_str_size esb_6: .blkb exp_str_size .address fab_8 fab_7: $fab nam=nam_7 nam_7: $nam esa=esb_7,ess=exp_str_size esb_7: .blkb exp_str_size .address fab_9 fab_8: $fab nam=nam_8 nam_8: $nam esa=esb_8,ess=exp_str_size esb_8: .blkb exp_str_size .address fab_10 fab_9: $fab nam=nam_9 nam_9: $nam esa=esb_9,ess=exp_str_size esb_9: .blkb exp_str_size ; ; start of code ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long ; ; integer function dopen(name, length, fab) ; ; return(OK/ERR) ; name=4 length=8 fab=12 ; .entry dopen ^m movl free_fab,r2 ; address of next free FAB beql 10$ ; if == 0, none left movl next_fab(r2),free_fab ; unlink FAB from list $fab_store fab=r2,fna=@name(ap),fns=@length(ap) $parse fab=r2 blbc r0,20$ ; lbc => error movl r2,@fab(ap) ; return FAB address movl #ok,r0 ; return(OK) ret 20$: movl r2,free_fab ; link back into free list 10$: movl #err,r0 ; return(ERR) ret ; ; subroutine dclose(fab) ; fab=4 ; .entry dclose ^m<> movl @fab(ap),r0 ; FAB address movl free_fab,next_fab(r0) ; link back into free list movl r0,free_fab ; ... ret ; ; integer function dfind(fab, buf) ; ; return(OK/EOF) ; fab=4 buf=8 ; .entry dfind ^m movl @fab(ap),r3 ; FAB address movl fab$l_nam(r3),r2 ; NAM address $nam_store nam=r2,rsa=@buf(ap),rss=#exp_str_size,rsl=#0 $search fab=r3 ; find next file in directory blbc r0,30$ ; lbc => error movzbl nam$b_rsl(r2),r0 ; length of resultant string addl2 buf(ap),r0 ; address of first free char clrb (r0) ; terminate with EOS movl #ok,r0 ; return(OK) ret 30$: movl #eof,r0 ; return(EOF) ret .end #-t- directory.mar 2687 ascii 15-Jan-84 14:45:11 #-h- fdel.mar 670 ascii 15-Jan-84 14:45:11 .title fdel ; ; subroutine to delete a file opened by the software tools io ; primitives ; ; call sequence status = fdel(rab) ; ; where rab is the integer descriptor from an openf call ; status is OK(0) or ERR(-3) ; rab=4 ok=0 err=-3 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry fdel ^m movl @rab(ap),r3 ; rab address in r3 movl rab$l_fab(r3),r2 ; fab address in r2 pushal @rab(ap) ; place address on stack calls #1,closef ; make sure file is closed $erase fab=r2 ; delete file blbc r0,error ; low bit clear => error movl #ok,r0 ; return success status ret error: movl #err,r0 ; return error status ret .end #-t- fdel.mar 670 ascii 15-Jan-84 14:45:11 #-h- gets.mar 1232 ascii 15-Jan-84 14:45:11 .title gets ; ; function to read a record from a VMS file ; ; call sequence n = gets(rab, buffer, size) ; ; where rab is the integer descriptor from an openf call ; buffer is a character buffer to receive the record ; size is the size of the buffer ; ; returns -3(ERR) if error reading record ; number of bytes read if successful ; err=-3 rab=4 ; offset from ap for rab address buf=8 ; offset from ap for buf address siz=12 ; offset from ap for size of buf .psect st_gets_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long msg: .ascid "Record too large for buffer - truncated" .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry gets ^m movl @rab(ap),r2 ; rab address in r2 movl buf(ap),rab$l_ubf(r2) ; user buffer address in rab movw @siz(ap),rab$w_usz(r2) ; size of buffer in rab $get rab=r2 blbs r0,10$ ; low bit set => success cmpl r0,#rms$_rtb ; record too big? bneq error ; no, real hard error pushal msg ; report error to user calls #1,g^lib$put_output ; ... 10$: movzwl rab$w_rsz(r2),r0 ; number of bytes in record returned movl rab$w_rfa(r2),rab_l_curbl(r2) ; save current RFA movw rab$w_rfa+4(r2),rab_l_curby(r2) ; ret error: movl #err,r0 ret .end #-t- gets.mar 1232 ascii 15-Jan-84 14:45:11 #-h- main.mar 252 ascii 15-Jan-84 14:45:12 .title tools$main ; ; this is the dummy main program to cause the tools run-time system ; to be invoked ; ok: .long 0 ; software tools OK status return ; start: .word 0 calls #0,g^initst calls #0,g^main pushal ok calls #1,g^endst ret .end start #-t- main.mar 252 ascii 15-Jan-84 14:45:12 #-h- mark.mar 530 ascii 15-Jan-84 14:45:12 .title mark ; ; subroutine to mark position of next record in file ; ; call sequence call mark(rab, adr1, adr2) ; ; where rab is the integer descriptor from an openf call ; adr1 is the address to receive the first address field ; adr2 is the address to receive the second address field ; rab=4 adr1=8 adr2=12 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry mark ^m movl @rab(ap),r2 ; rab address in r2 movl rab_l_curbl(r2),@adr1(ap) ; return RFA movw rab_l_curby(r2),@adr2(ap) ; ret .end #-t- mark.mar 530 ascii 15-Jan-84 14:45:12 #-h- myopen.mar 896 ascii 15-Jan-84 14:45:12 .title myopen $namdef .psect st_myopen_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long myfab: $fab fna=myfna,nam=mynam myfna: .blkb 64 myesa: .blkb 64 mynam: $nam esa=myesa,ess=64 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry myopen ^m moval myfab,r3 ; fab address in r3 clrl r2 ; r2 is character counter movab myfna,r1 ; destination array movl 4(ap),r0 ; source array loop: cmpb #0,(r0) beql endstr movb (r0)+,(r1)+ incl r2 brb loop endstr: movb r2,fab$b_fns(r3) $parse fab=r3 $search fab=r3 moval mynam,r8 ; address of nam in r8 addl3 #nam$t_dvi,r8,r6 ; source address in r6 addl3 #18,8(ap),r7 ; destination addr in r7 movc3 #16,(r6),(r7) ; copy characters addl3 #nam$w_fid,r8,r6 ; addl3 #34,8(ap),r7 movc3 #6,(r6),(r7) addl3 #nam$w_did,r8,r6 addl3 #40,8(ap),r7 movc3 #6,(r6),(r7) ret .end #-t- myopen.mar 896 ascii 15-Jan-84 14:45:12 #-h- openf.mar 5057 ascii 15-Jan-84 14:45:12 .title openf ; ; function called from fortran to open rms files for ; software tools ; ; calling sequence: ; status = openf(ext, ftype, ccontrol, access, age, rab) ; ; character ext ; array with file name (assumed in upper case) ; integer ftype ; file type -- character(0) or binary(1) ; integer ccontrol ; list(0) or fort(1) ; integer access ; read(1), write(2), readwrite(3), append(4) ; integer age ; old(-1), unk(0), or new(1) ; integer rab ; descriptor to be used with all file prims ; ; status returned: err if error ; ftype if successful ; ; necessary parameters (values of rat4 symbols) ; err=-3 character=0 binary=1 ext=4 typ=8 cc=12 acc=16 age=20 rab=24 $devdef ; Device chracteristics .psect st_openf_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long name_block: $nam ; name block for determining process-permanent files ; ; ; start of code ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry openf ^m calls #0,getrab ; get a rab address movl r0,r3 ; move rab to non-volatile register bneq 10$ brw operr ; if 0, no rab's available 10$: movl rab$l_fab(r3),r2 ; fab address in r2 $fab_store fab=r2,- ; runtime initialization of fab mrs=#0,- ; no maximum record size org=seq,- ; seqential organization alq=#0,- ; no initial alocation on new files fsz=#0,- ; no vfc fields on created files fop=tef,- ; truncate file upon closing shr=,- ; read sharing if writing file rfm=var ; assume character file $rab_store rab=r3,- ; runtime initialization of rab rac=seq ; sequential record access clrl rab$l_rop(r3) ; clear record processing options pushl ext(ap) ; address of file name on stack calls #1,length ; calculate its length pushr #^m ; save registers affected by movc movc3 r0,@ext(ap),@fab$l_fna(r2) ; copy string into fna buffer popr #^m ; restore registers movb r0,fab$b_fns(r2) ; size of filespec in fab blbc @typ(ap),cctrl ; if lbc, character file $fab_store fab=r2,- ; set up fab for binary file rfm=fix,- ; fixed-length records mrs=#512 ; 512 byte blocks brb access ; skip carriage control stuff cctrl: $fab_store fab=r2,rat=cr ; assume list carriagecontrol blbc @cc(ap),access ; list carriage control $fab_store fab=r2,rat=ftn ; fortran carriage control access: casel @acc(ap),#1,#4 ; case on access mode case1: .word read-case1 ; READ .word write-case1 ; WRITE .word readwr-case1 ; READWRITE .word append-case1 ; APPEND brw conerr ; out of range read: $fab_store fab=r2,fac=,- ; read access shr= ; permit one writer, many readers $rab_store rab=r3,rop= ; enable readahead brb type write: $fab_store fab=r2,fac=; write access $rab_store rab=r3,rop= ; write behind and truncate brb type readwr: $fab_store fab=r2,fac= ; readwrite access $rab_store rab=r3,rop= brb type append: $fab_store fab=r2,fac= ; append access $rab_store rab=r3,rop= ; connect at EOF type: moval name_block,fab$l_nam(r2); fill in name block upon open addl3 #1,@age(ap),r0 ; place age + 1 in r0 casel r0,#0,#2 ; case on age + 1 case2: .word old-case2 ; OLD file .word unk-case2 ; UNKNOWN file .word new-case2 ; NEW file brw conerr ; out of range old: $open fab=r2 brb tsterr unk: $fab_store fab=r2,fop= ; create if new: $create fab=r2 tsterr: clrl fab$l_nam(r2) ; no longer need name block blbs r0,25$ ; low bit set ==> success brw conerr ; ERROR 25$: bbs #nam$v_ppf,name_block+nam$l_fnb,20$ ; no delete if process ; permanent file bbc #dev$v_fod,fab$l_dev(r2),20$ ; dont close non-FODs cmpl @acc(ap),#2 ; WRITE access? bneq 20$ ; NO bbs #fab$v_ftn,fab$b_rat(r2),20$ ; no remove/create if cctrl bbs #fab$v_cr,fab$b_rat(r2),20$ ; ... $close fab=r2 ; close the file $erase fab=r2 ; delete the file $fab_store fab=r2,fop=tef ; truncate file upon closing bisb #fab$m_cr,fab$b_rat(r2) ; set to LIST carriage control 30$: $create fab=r2 ; create new file 20$: movl r3,@rab(ap) ; return rab address $connect rab=r3 ; connect record stream blbc r0,conerr ; lbc => ERROR clrl rab$l_ctx(r3) ; 0 ==> do not truncate at close bbs #nam$v_ppf,name_block+nam$l_fnb,40$ ; leave proc perm file alone bbc #dev$v_fod,fab$l_dev(r2),40$ ; as well as non-FODs cmpl @acc(ap),#2 ; WRITE access? bneq 40$ ; NO bbs #fab$v_ftn,fab$b_rat(r2),50$ ; FTN carriage control? bisb #fab$m_cr,fab$b_rat(r2) ; set to LIST carriage ctrl 50$: ; $rewind rab=r3 ; find first record; guarantees tpt incl rab$l_ctx(r3) ; 1 == > truncate file at close 40$: movl #character,r0 ; assume a character file bitb #fab$c_var,fab$b_rfm(r2); check for file type bneq done movl #binary,r0 ; have a binary file done: ret conerr: $close fab=r2 ; close file pushl r3 calls #1,putrab ; return rab to linked list operr: movl #err,r0 ; return error status ret .end #-t- openf.mar 5057 ascii 15-Jan-84 14:45:12 #-h- point.mar 1294 ascii 15-Jan-84 14:45:13 .title point ; ; ; subroutine which positions software tools file to a specific ; disk address. ; ; call sequence: status = point(rab, addr1, addr2) ; ; where ; rab is the integer descriptor from the openf call ; addr1,addr2 are the integers returned by a markl call ; ; returns ; OK(0) if successful ; EOF(-1) if successful and at end of file ; ERR(-3) if any error in positioning file ; ; ok=0 eof=-1 err=-3 rab=4 adr1=8 adr2=12 ; ; ; local buffer for dummy reads ; .psect st_point_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long buf: .blkb 4 ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry point ^m movl @rab(ap),r2 ; rab address in r2 movl @adr1(ap),rab$w_rfa(r2) ; copy block number beql rewind ; if 0, rewind file movw @adr2(ap),rab$w_rfa+4(r2) ; copy byte offset movb rab$b_rac(r2),-(sp) ; save old rac $rab_store rab=r2,rac=rfa ; set to RFA $find rab=r2 ; position file movb (sp)+,rab$b_rac(r2) ; restore rac field moval buf,rab$l_ubf(r2) ; set up for dummy read movw #4,rab$w_usz(r2) ; $get rab=r2 ; get sets up next record brb retrn rewind: $rewind rab=r2 ; rewind file to set next rec retrn: movl @adr1(ap),rab_l_curbl(r2) ; fill in current record movzwl @adr2(ap),rab_l_curby(r2) ; ret .end #-t- point.mar 1294 ascii 15-Jan-84 14:45:13 #-h- puts.mar 1227 ascii 15-Jan-84 14:45:13 .title puts ; ; subroutine to put a record to a VMS file ; ; call sequence status = puts(rab, buffer, n) ; ; where rab is the integer descriptor from an openf call ; buffer is the buffer containing the record to be put ; n is the number of bytes to put ; ; status returned is OK or ERR ; err=-3 ok=0 rab=4 buf=8 num=12 .psect st_puts_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long inpdsc: .long 256 .address errbuf outdsc: .long 256 .address errbuf errbuf: .blkb 256 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .enabl lsb .entry puts ^m movl #1,r3 ; initialize retry count movl @rab(ap),r2 ; rab address in r2 movl buf(ap),rab$l_rbf(r2) ; buffer address in rab movw @num(ap),rab$w_rsz(r2) ; # of bytes to put 1$: $put rab=r2 blbc r0,error ; low bit clear => error movl rab$w_rfa(r2),rab_l_curbl(r2) ; save RFA movzwl rab$w_rfa+4(r2),rab_l_curby(r2) ; bisl2 #2,rab$l_ctx(r2) ; set bit to indicate that put was done movl #ok,r0 ret error: decl r3 ; decrement retry count beql 1$ ; try it again $getmsg_s rab$l_stv(r2),outdsc,inpdsc ; format message pushal outdsc ; arg for lib$put_output calls #1,g^lib$put_output ; tell the user movl #err,r0 ret .end #-t- puts.mar 1227 ascii 15-Jan-84 14:45:13 #-h- rablst.mar 2925 ascii 15-Jan-84 14:45:14 .title rablst ; ; functions to get and put rms data structures ; used by openf and closef for software tools ; ; calling sequences: ; rab = getrab(0) ; argument is a dummy one ; call putrab(rab) ; ; ; linked list of rab's and fab's follow: ; rab_l_next==-12 rab_l_curbl==-8 rab_l_curby==-4 .psect st_rablst_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long rabhd: .address rab1 ;rab1 .address rab2 .blkl 1 .blkl 1 rab1: $rab fab=fab1 fab1: $fab fna=fna1 fna1: .blkb 104 ;rab2 .address rab3 .blkl 1 .blkl 1 rab2: $rab fab=fab2 fab2: $fab fna=fna2 fna2: .blkb 104 ;rab3 .address rab4 .blkl 1 .blkl 1 rab3: $rab fab=fab3 fab3: $fab fna=fna3 fna3: .blkb 104 ;rab4 .address rab5 .blkl 1 .blkl 1 rab4: $rab fab=fab4 fab4: $fab fna=fna4 fna4: .blkb 104 ;rab5 .address rab6 .blkl 1 .blkl 1 rab5: $rab fab=fab5 fab5: $fab fna=fna5 fna5: .blkb 104 ;rab6 .address rab7 .blkl 1 .blkl 1 rab6: $rab fab=fab6 fab6: $fab fna=fna6 fna6: .blkb 104 ;rab7 .address rab8 .blkl 1 .blkl 1 rab7: $rab fab=fab7 fab7: $fab fna=fna7 fna7: .blkb 104 ;rab8 .address rab9 .blkl 1 .blkl 1 rab8: $rab fab=fab8 fab8: $fab fna=fna8 fna8: .blkb 104 ;rab9 .address raba .blkl 1 .blkl 1 rab9: $rab fab=fab9 fab9: $fab fna=fna9 fna9: .blkb 104 ;raba .address rabb .blkl 1 .blkl 1 raba: $rab fab=faba faba: $fab fna=fnaa fnaa: .blkb 104 ;rabb .address rabc .blkl 1 .blkl 1 rabb: $rab fab=fabb fabb: $fab fna=fnab fnab: .blkb 104 ;rabc .address rabd .blkl 1 .blkl 1 rabc: $rab fab=fabc fabc: $fab fna=fnac fnac: .blkb 104 ;rabd .address rabe .blkl 1 .blkl 1 rabd: $rab fab=fabd fabd: $fab fna=fnad fnad: .blkb 104 ;rabe .address rabf .blkl 1 .blkl 1 rabe: $rab fab=fabe fabe: $fab fna=fnae fnae: .blkb 104 ;rabf .long 0 .blkl 1 .blkl 1 rabf: $rab fab=fabf fabf: $fab fna=fnaf fnaf: .blkb 104 ; ; ; entry point for getrab ; ; call sequence: rab = getrab(0) ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry getrab ^m<> moval rabhd,r1 ; listhead in r1 movl (r1),r0 ; address of free node in r0 beql retrn ; if 0, then no more free nodes movl rab_l_next(r0),(r1) ; relink list clrl rab_l_curbl(r0) ; initialize current block value clrl rab_l_curby(r0) ; initialize current byte value retrn: ret ; ; ; entry point for putrab ; ; call sequence call putrab(%val(rab)) ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry putrab ^m<> movl 4(ap),r0 ; address of node to be returned movl rabhd,r1 ; address of first free node in r1 loop: tstl r1 beql retok ; have reached end of linked list cmpl r0,r1 ; compare addresses of nodes beql notok ; user trying to return node twice movl rab_l_next(r1),r1 ; address of next free node in r1 brb loop retok: moval rabhd,r1 ; listhead in r1 movl (r1),rab_l_next(r0) ; returned node points to top node movl r0,(r1) ; listhead now points to returned node notok: ret .end #-t- rablst.mar 2925 ascii 15-Jan-84 14:45:14 #-h- rdpmpt.mar 1465 ascii 15-Jan-84 14:45:14 .title rdpmpt ; ; function to read a record from a VMS file, prompting first ; ; call sequence n = rdpmpt(rab, prompt, psize, buffer, size) ; ; where rab is the integer descriptor from an openf call ; prompt is the prompt string ; psize is the length of the prompt string ; buffer is a character buffer to receive the record ; size is the size of the buffer ; ; returns -3(ERR) if error reading record ; number of bytes read if successful ; err=-3 rab=4 ; offset from ap for rab address pmt=8 ; offset from ap for prompt address psz=12 ; offset from ap for prompt length buf=16 ; offset from ap for buf address siz=20 ; offset from ap for size of buf .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry rdpmpt ^m movl @rab(ap),r2 ; rab address in r2 movl buf(ap),rab$l_ubf(r2) ; user buffer address in rab movw @siz(ap),rab$w_usz(r2) ; size of buffer in rab movl pmt(ap),rab$l_pbf(r2) ; prompt buffer address in rab movb @psz(ap),rab$b_psz(r2) ; length of prompt buffer in rab bisl #rab$m_pmt,rab$l_rop(r2) ; set bit for prompting $get rab=r2 bicl #rab$m_pmt,rab$l_rop(r2) ; turn off prompting blbc r0,error ; low bit clear => error movzwl rab$w_rsz(r2),r0 ; number of bytes in record returned addl3 r0,buf(ap),r1 ; address of first free byte movb #10,(r1)+ ; append NEWLINE character clrb (r1) ; terminate with EOS incl r0 ; include NEWLINE in count ret error: movl #err,r0 ret .end #-t- rdpmpt.mar 1465 ascii 15-Jan-84 14:45:14 #-h- reads.mar 1090 ascii 15-Jan-84 14:45:15 .title reads ; ; function to read a block from a VMS file ; ; call sequence n = reads(rab, start, buffer, size) ; ; where rab is the integer descriptor from an openf call ; start is the starting virtual block number for read ; buffer is a character buffer to receive the block ; size is the size of the buffer ; ; returns -3(ERR) if error reading record ; number of bytes read if successful ; err=-3 eof=-1 rab=4 ; offset from ap for rab address start=8 ; offset from ap for start VBN buf=12 ; offset from ap for buf address siz=16 ; offset from ap for size of buf .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry reads ^m movl @rab(ap),r2 ; rab address in r2 movl @start(ap),rab$l_bkt(r2); starting block number movl buf(ap),rab$l_ubf(r2) ; user buffer address in rab movw @siz(ap),rab$w_usz(r2) ; size of buffer in rab $read rab=r2 blbc r0,error ; low bit clear => error movzwl rab$w_rsz(r2),r0 ; number of bytes in record returned ret error: cmpl r0,#rms$_eof bneq iserr movl #eof,r0 ret iserr: movl #err,r0 ret .end #-t- reads.mar 1090 ascii 15-Jan-84 14:45:15 #-h- rename.mar 1100 ascii 15-Jan-84 14:45:15 .title rename ; ; ; routine renames files using RMS ; ; call sequence: status = rename(name1, name2) ; ; inputs: name1, name2 are old and new names for file ; ; outputs: OK(0) if successful ; ERR(-3) if error ; ; esssize=104 ; size of expanded string name1=4 ; ap offset of name1 name2=8 ok=0 err=-3 .psect st_rename_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long nam1: $nam esa=esa1,ess=esssize nam2: $nam esa=esa2,ess=esssize fab1: $fab nam=nam1 fab2: $fab nam=nam2 esa1: .blkb esssize esa2: .blkb esssize .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry rename ^m moval fab1,r2 ; oldfab in r2 moval fab2,r3 ; newfab in r3 movl name1(ap),fab$l_fna(r2) ; place string address in fab pushl name1(ap) calls #1,length ; calculate length of filespec movb r0,fab$b_fns(r2) ; length of filespec in fab movl name2(ap),fab$l_fna(r3) ; same for new filespec pushl name2(ap) calls #1,length movb r0,fab$b_fns(r3) $rename oldfab=r2, newfab=r3 blbc r0,error ; low bit clear => ERROR movl #ok,r0 ret error: movl #err,r0 ret .end #-t- rename.mar 1100 ascii 15-Jan-84 14:45:15 #-h- system.mar 6512 ascii 15-Jan-84 14:45:15 .title system .sbttl comments and symbol definitions ;+ ; integer function system(buffer) ; ; character buffer(ARB) ; ; return(0/1) if spawn failed/succeeded ; ; the EOS-terminated command in buffer is spawned to the local ; command interpreter (DCL). If the spawn succeeded, a value of ; 1 is returned, else 0. If buffer contains a null command, a ; value of 1 is returned. ; ; sys$system:loginout.exe is spawned as a sub-process reading ; a mailbox for its input. After some preliminary DCL commands ; to force the environment to be correct, the command in buffer ; is executed as ; ; @st_bin:dodcl/out='term' 'command' ; ; where 'term' is replaced by the translation of TT and 'command' ; is the user specified command. This command procedure is ; designed to perform some more hacks to get the environment in ; shape and to define the tools as foreign symbols. ;- $jpidef $dibdef $accdef $pqldef $devdef buffer=4 .page .sbttl impure data ; ; impure data ; .psect st_system_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long pid: .blkl 1 ; our pid goes here prib: .blkl 1 ; our base priority goes here authpr: .blkq 1 ; our authorization privelege mask goes here pidbuf: .blkb 8 ; buffer for formatted pid trmbuf: .ascii "SYSTRM" ; name of termination mailbox trmpid: .blkb 8 ; ... argbuf: .ascii "SYSARG" ; name of argument mailbox argpid: .blkb 8 ; ... prcbuf: .ascii "SYS" ; sub-process name prcpid: .blkb 8 ; ... trmchn: .blkw 1 ; space for termination mailbox channel trmunt: .blkw 1 ; space for termination mailbox unit buf: .blkb 512 ; termporary buffer ttybuf: .blkb 64 ; buffer for TT translation dumdsc: .blkq 1 ; dummy descriptor ttydsc: .long 64 ; resultant buffer for trnlog of TT .address ttybuf ; ... length: .blkw 1 ; location for length cmddsc: .blkq 1 ; command descriptor argchn: .blkw 1 ; location for argument mailbox channel trmsts: .blkb acc$k_termlen ; termination mbox message buffer .page .sbttl pure data ; ; pure data ; jpilst: .word 4,jpi$_pid ; fetch our pid .address pid ; ... .long 0 ; ... .word 4,jpi$_prib ; fetch our base priority .address prib ; ... .long 0 ; ... .word 8,jpi$_authpriv ; fetch our auth privelege mask .address authpr ; ... .long 0 ; ... .long 0 ; end of jpi list pidfmt: .ascid "!XL" ; format string for pid format trmdsc: .long 14 ; descriptor for termination mailbox .address trmbuf ; ... argdsc: .long 14 ; descriptor for argument mailbox .address argbuf ; ... prcdsc: .long 11 ; descriptor for process name .address prcbuf ; ... tt: .ascid "TT" ; descriptor for TT nldsc: .ascid "NLA0:" ; descriptor for null device imgdsc: .ascid "SYS$SYSTEM:LOGINOUT.EXE" ; image to run nover: .ascii "$SET NOVERIFY" ; tell loginout not to mumble at user noverl=.-nover assfmt1: .ascid "$ASSIGN !AS TT" ; format string for assign cmd assfmt2: .ascid "$ASSIGN !AS SYS$COMMAND" cmdfmt: .ascid "$@ST_BIN:DODCL/OUT=!AS !AS" ; command format string quotas: .byte pql$_astlm .long 10 .byte pql$_biolm .long 6 .byte pql$_bytlm .long 8192 .byte pql$_cpulm .long 0 .byte pql$_diolm .long 6 .byte pql$_fillm .long 15 .byte pql$_pgflquota .long 1024 .byte pql$_prclm .long 2 .byte pql$_tqelm .long 8 .byte pql$_wsdefault .long 300 .byte pql$_wsquota .long 750 .byte pql$_listend .page .sbttl code ; ; code ; .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry system ^m tstw trmchn ; initialized yet? beql 1$ ; NO brw 10$ ; continue 1$: $getjpi_s itmlst=jpilst ; fetch pid, base_prio and priv_mask blbs r0,2$ ; lbs => success brw 5$ ; error 2$: movl #8,dumdsc ; prepare descriptor for fao movab pidbuf,dumdsc+4 ; ... $fao_s ctrstr=pidfmt,outbuf=dumdsc,p1=pid ; format pid blbs r0,3$ ; lbs => success brw 5$ ; error 3$: movc3 #8,pidbuf,trmpid ; copy into name strings movc3 #8,pidbuf,argpid ; ... movc3 #8,pidbuf,prcpid ; ... $crembx_s ,trmchn,#100,,#0,,trmdsc ; create termination mailbox blbs r0,6$ ; lbs => success brw 5$ ; error 6$: movl #512,dumdsc ; prepare descriptor for getchn movab buf,dumdsc+4 ; ... $getchn_s trmchn,,dumdsc ; get channel information blbc r0,4$ ; lbc => error movw buf+dib$w_unit,trmunt ; save unit number $trnlog_s tt,length,ttydsc ; translate TT movw length,ttydsc ; copy length into descriptor cmpb #^x1b,ttybuf ; process permanent file? bneq 12$ ; NO addl2 #4,ttydsc+4 ; revise descriptor for tty subl2 #4,ttydsc ; ... 12$: $getdev_s ttydsc,,dumdsc ; get device information blbc r0,11$ ; lbc => error, use nla0: bbs #dev$v_trm,buf+dib$l_devchar,10$ ; if term, OK 11$: movq nldsc,ttydsc ; redefine tty to be null device brb 10$ ; continue to hard stuff 4$: $dassgn_s trmchn ; deassign channel 5$: clrw trmchn ; initialization not complete clrl r0 ; return(0) ret 10$: clrl r0 ; initialize length of buffer movl buffer(ap),r1 ; starting address 20$: tstb (r1)+ ; null character yet? beql 30$ ; YES incl r0 ; increment length brb 20$ ; try again 30$: movl r0,cmddsc ; fill in command descriptor bneq 40$ ; we have something to do brw return_1 ; null command => immediate success 40$: movl buffer(ap),cmddsc+4 ; complete command descriptor $crembx_s ,argchn,#512,,#0,,argdsc ; create argument mailbox blbs r0,50$ ; lbs => success brw return_0 ; error 50$: $creprc_s ,imgdsc,argdsc,nldsc,nldsc,authpr,quotas,prcdsc,prib,,trmunt blbs r0,60$ ; lbs => success $dassgn_s argchn ; deassign the channel brw return_0 ; error 60$: $output argchn,#noverl,nover ; $ set noverify movl #512,dumdsc ; initialize dummy descriptor movab buf,dumdsc+4 ; ... moval ttydsc,r0 ; fetch address of descriptor $fao_s assfmt1,length,dumdsc,r0 ; format string $output argchn,length,buf ; $assign 'term' TT moval ttydsc,r0 ; fetch address of descriptor $fao_s assfmt2,length,dumdsc,r0 ; format string $output argchn,length,buf ; $assign 'term' SYS$COMMAND moval ttydsc,r0 ; fetch address of descriptor moval cmddsc,r1 ; fetch address of descriptor $fao_s cmdfmt,length,dumdsc,r0,r1 ; format string $output argchn,length,buf ; $@dodcl/out='term' 'command' $qiow_s ,argchn,#io$_writeof ; write EOF on mbox $dassgn_s argchn ; deassign channel $input trmchn,#acc$k_termlen,trmsts ; read return message movl trmsts+acc$l_finalsts,r1; fetch return status beql return_1 ; OK if status == 0 blbs r1,return_1 ; OK if low bit set return_0: clrl r0 ; return(0) ret return_1: movl #1,r0 ; return(1) ret .end #-t- system.mar 6512 ascii 15-Jan-84 14:45:15 #-h- writes.mar 533 ascii 15-Jan-84 14:45:16 .title writes ; ; subroutine to put a block to a VMS file ; ; call sequence call writes(rab, buffer, n) ; ; where rab is the integer descriptor from an openf call ; buffer is the buffer containing the record to be put ; n is the number of bytes to put ; rab=4 buf=8 num=12 .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry writes ^m movl @rab(ap),r2 ; rab address in r2 movl buf(ap),rab$l_rbf(r2) ; buffer address in rab movw @num(ap),rab$w_rsz(r2) ; # of bytes to put $write rab=r2 ret .end #-t- writes.mar 533 ascii 15-Jan-84 14:45:16 #-h- getpriv.mar 4577 ascii 15-Jan-84 14:45:17 .title get_priv ;+ ; integer function get_priv(which_priv, pid, prcnam, buf) ; ; return(OK/ERR) ; ; fetches the which_priv mask with a getjpi and formats the ; privelege names in buf as name@ename@ename@e...@e@n ; the user must make sure that the buffer is large enough ; the name of the process is returned as a 0-byte terminated string ; ; valid values for which_priv are authpriv, curpriv, imagpriv, procpriv ;- $jpidef $prvdef which_priv=4 pid=8 prcnam=12 buf=16 ok=0 err=-3 max_priv=prv$v_bypass ; as of version 2.x .psect st_getpriv_data rel,con,gbl,noexe,wrt,rd,pic,noshr,usr,novec,long jpi_list: .word 8 ; size of buffer cmd: .word jpi$_curpriv ; fetch current priveleges .address priv_buf ; address of buffer .long 0 ; no length desired .word 16 ; buffer size for process name .word jpi$_prcnam ; fetch process name prc_buf:.long 0 ; buffer address placed here .address length ; address to receive length .long 0 ; end of list length: .blkw 1 ; word for length of process name priv_buf: .blkq 1 ; quadword for privelege mask names: .address name0 .address name1 .address name2 .address name3 .address name4 .address name5 .address name6 .address name7 .address name8 .address name9 .address name10 .address name11 .address name12 .address name13 .address name14 .address name15 .address name16 .address name17 .address name18 .address name19 .address name20 .address name21 .address name22 .address name23 .address name24 .address name25 .address name26 .address name27 .address name28 .address name29 .address name30 .address name31 .address name32 .address name33 .address name34 .address name35 .address name36 .address name37 .address name38 .address name39 .address name40 .address name41 .address name42 .address name43 .address name44 .address name45 .address name46 .address name47 .address name48 .address name49 .address name50 .address name51 .address name52 .address name53 .address name54 .address name55 .address name56 .address name57 .address name58 .address name59 .address name60 .address name61 .address name62 .address name63 name0: .asciz "cmkrnl" name1: .asciz "cmexec" name2: .asciz "sysnam" name3: .asciz "grpnam" name4: .asciz "allspool" name5: .asciz "detach" name6: .asciz "diagnose" name7: .asciz "log_io" name8: .asciz "group" name9: .asciz "noacnt" name10: .asciz "prmceb" name11: .asciz "prmmbx" name12: .asciz "pswapm" name13: .asciz "altpri" name14: .asciz "setprv" name15: .asciz "tmpmbx" name16: .asciz "world" name17: .asciz "mount" name18: .asciz "oper" name19: .asciz "exquota" name20: .asciz "netmbx" name21: .asciz "volpro" name22: .asciz "phy_io" name23: .asciz "bugchk" name24: .asciz "prmgbl" name25: .asciz "sysgbl" name26: .asciz "pfnmap" name27: .asciz "shmem" name28: .asciz "sysprv" name29: .asciz "bypass" name30: .asciz "syslck" name31: .asciz "Priv_1F" name32: .asciz "Priv_20" name33: .asciz "Priv_21" name34: .asciz "Priv_22" name35: .asciz "Priv_23" name36: .asciz "Priv_24" name37: .asciz "Priv_25" name38: .asciz "Priv_26" name39: .asciz "Priv_27" name40: .asciz "Priv_28" name41: .asciz "Priv_29" name42: .asciz "Priv_2A" name43: .asciz "Priv_2B" name44: .asciz "Priv_2C" name45: .asciz "Priv_2D" name46: .asciz "Priv_2E" name47: .asciz "Priv_2F" name48: .asciz "Priv_30" name49: .asciz "Priv_31" name50: .asciz "Priv_32" name51: .asciz "Priv_33" name52: .asciz "Priv_34" name53: .asciz "Priv_35" name54: .asciz "Priv_36" name55: .asciz "Priv_37" name56: .asciz "Priv_38" name57: .asciz "Priv_39" name58: .asciz "Priv_3A" name59: .asciz "Priv_3B" name60: .asciz "Priv_3C" name61: .asciz "Priv_3D" name62: .asciz "Priv_3E" name63: .asciz "Priv_3F" .psect st_pure_code rel,con,lcl,exe,nowrt,rd,pic,shr,usr,novec,long .entry get_priv ^m movw @which_priv(ap),cmd ; which privilege mask to get movl prcnam(ap),prc_buf ; store address for proc name $getjpi_s efn=#0,pidadr=@pid(ap),itmlst=jpi_list blbc r0,10$ ; error $waitfr_s efn=#0 ; wait for completion movzwl length,r0 ; length of proc name addl2 prcnam(ap),r0 ; address of EOS clrb (r0) ; terminate it movl buf(ap),r0 ; output buffer address clrl r2 ; start at bit 0 moval names,r3 ; start of pointers 5$: bbc r2,priv_buf,7$ ; if bit clear, try next movl (r3)[r2],r1 ; address of string 6$: movb (r1)+,(r0)+ ; copy character bneq 6$ ; go again 7$: aobleq #max_priv,r2,5$ ; try next privelege bit movb #10,(r0) ; terminate with newline movl #ok,r0 ; return(OK) ret 10$: movl #err,r0 ; return(ERR) ret .end #-t- getpriv.mar 4577 ascii 15-Jan-84 14:45:17 #-t- prim.m 42428 ascii 15-Jan-84 15:26:06 #-h- prim.r 107995 ascii 15-Jan-84 15:26:12 #-h- defns 3263 ascii 15-Jan-84 14:46:44 # definitions for primitives in general (VAX/VMS) define(NNFILES,MAXOFILES) define(NEWREAD,99) # flag for creating new file define(SCRATCH,98) # flag for scratch file define(INPUTMODE,0) # flag for mode of io define(OUTPUTMODE,1) define(CHARAC,0) # definitions for openf calls define(BINAR,1) define(LISTCC,0) define(FORTCC,1) define(OLDAGE,-1) define(UNKAGE,0) define(NEWAGE,1) define(NODEVICE,0) # ratfor unit is not assigned define(TTYDEVICE,1) # unit is assigned to tty device define(MBXDEVICE,2) # unit is assigned to mailbox define(OTHERDEVICE,3) # unit is assigned to other device define(MAX_TIMEOUT,31557600) # default timeout == 1 year (dpm 8-Jun-81) # definitions for spawn primitives define(NTASKS,5) define(SSWASCLR,1) define(QIOW,sys$qiow) define(QIO,sys$qio) define(NFOREGROUND,5) define(NPROCESSES,8) define(JPITQLM,1040) define(JPIBYTLM,794) define(JPIPGFL,1038) define(BYTLMMIN,1024) define(FILLMMIN,6) define(PGFLMIN,1024) define(PRCLMLEV1,5) define(PRCLMLEV2,2) define(TQLMMIN,2) define(pqlastlm,1) define(pqlbiolm,2) define(pqlbytlm,3) define(pqlcpulm,4) define(pqldiolm,5) define(pqlfillm,6) define(pqlpgflquota,7) define(pqlprclm,8) define(pqltqelm,9) define(pqlwsquota,10) define(pqlwsdefault,11) define(pqllistend,0) define(ASTLM,10) define(BIOLM,6) define(BYTLM,6000) define(CPULM,0) define(DIOLM,6) define(FILLM,15) define(PGFLQUOTA,1024) define(PRCLM,2) define(TQELM,8) define(WSQUOTA,512) define(WSDEFAULT,256) define(BFILLM,45) define(BPRCLM,10) define(BTQELM,24) define(BBYTLM,30720) define(BPGFLQ,30000) define(BACKPRIORITY,1) define(TERMSGSIZEBYTE,84) define(QUOTALISTSIZE,56) define(MAXDEPTH,5) define(jpilst, J1($1) J2($1) J3($1)) define(J1,integer*2 $1(8)) define(J2,integer*4 $1a) define(J3,equivalence ($1a,$1(3))) # definitions for directory primitives define(TCOLWIDTH,24) define(BLOCKWIDTH,9) # (dpm 6-Jul-81) define(NDIRECTS,10) # Note that in the following definitions all VMS names containing `$' # characters have them replaced with `_' characters, except where this # would cause two adjacent `_' characters. In these cases the `$' is # simply omitted. (dpm 16-Jun-81) # VMS I/O function codes define(IO_READLBLK,16%21) define(IO_READVBLK,16%31) define(IO_TTYREADALL,16%3A) define(IO_WRITEVBLK,16%30) # VMS I/O function modifier masks define(IO_M_NOECHO,16%40) define(IO_M_NOFILTER,16%200) define(IO_M_NOFORMAT,16%100) define(IO_M_NOW,16%40) define(IO_M_TIMED,16%80) define(IO_CTRLCAST,16%123) # IO$_SETMODE | IO$M_CTRLCAST # VMS Job/Process information request codes define(JPI_AUTHPRIV,16%412) define(JPI_CURPRIV,16%400) define(JPI_IMAGPRIV,16%413) define(JPI_PROCPRIV,16%204) define(JPI_CPUTIM,16%407) define(JPI_FILLM,16%40F) define(JPI_IMAGNAME,16%207) define(JPI_LOGINTIM,16%206) define(JPI_OWNER,16%303) define(JPI_PAGEFLTS,16%40A) define(JPI_PID,16%319) define(JPI_PRCLM,16%408) define(JPI_PRCNAM,16%31C) define(JPI_PRIB,16%309) define(JPI_STATE,16%306) define(JPI_UIC,16%304) define(JPI_USERNAME,16%202) # VMS system service return codes define(SS_BUFFEROVF,16%601) define(SS_CONTROLO,16%609) define(SS_NORMAL,1) define(SS_NOTRAN,16%629) define(SS_SUPERCEDE,16%631) define(SS_TIMEOUT,16%22C) # # definitions to hide entry points # define(lookup,pr_lookup) define(instal,pr_instal) #-t- defns 3263 ascii 15-Jan-84 14:46:44 #-h- amove 994 ascii 15-Jan-84 14:46:44 ### AMove Move (or rename) `file1' to `file2'. integer function amove( name1, name2) character name1(FILENAMESIZE), name2(FILENAMESIZE) character temp1(FILENAMESIZE), temp2(FILENAMESIZE) integer status, junk integer index, rename, remove # function(s) filedes old, new filedes create, open # function(s) include io if( index( name1, '/') > 0 | index( name1, '\') > 0 ) call mklocl( name1, temp1) else call strcpy( name1, temp1) if( index( name2, '/') > 0 | index( name2, '\') > 0 ) call mklocl( name2, temp2) else call strcpy( name2, temp2) call upper(temp1) call upper(temp2) new = open( temp2, READ) if( new != ERR ) { call close(new) junk = remove(temp2) } if( rename( temp1, temp2) == ERR ) { old = open( temp1, READ) if( old == ERR ) return(ERR) new = create( temp2, WRITE) if( new == ERR ) { call close(old) return(ERR) } call fcopy( old, new) call close(old) call close(new) junk = remove(temp1) } return(OK) end #-t- amove 994 ascii 15-Jan-84 14:46:44 #-h- appred 351 ascii 15-Jan-84 14:46:45 ### AppRed Process APPEND redirection for `spawn'. subroutine appred( fd, c, file, buf) filedes fd integer i integer length # function(s) character buf(ARGBUFSIZE), c, file(FILENAMESIZE) i = length(buf) + 1 call chcopy( ' ', buf, i) call chcopy( c, buf, i) call chcopy( c, buf, i) call stcopy( file, 1, buf, i) call close(fd) return end #-t- appred 351 ascii 15-Jan-84 14:46:45 #-h- appstr 210 ascii 15-Jan-84 14:46:45 ### AppStr Append `str1' to `str2'. subroutine appstr( str1, str2) character str1(ARB), str2(ARB) integer i integer length # function(s) i = length(str2) + 1 call scopy( str1, 1, str2, i) return end #-t- appstr 210 ascii 15-Jan-84 14:46:45 #-h- arggen 436 ascii 15-Jan-84 14:46:45 ### ArgGen Generate name of arg mailbox for process `pname' into `bname'. subroutine arggen( pname, bname) character pname(ARB), bname(ARB) integer i, j string argstr "arg" j = 1 call stcopy( argstr, 1, bname, j) for( i = 1 ; pname(i) != EOS ; i = i + 1 ) { if( pname(i) == '&' ) call chcopy( '_', bname, j) else if( pname(i) != '.' ) call chcopy( pname(i), bname, j) } bname(j) = EOS call upper(bname) return end #-t- arggen 436 ascii 15-Jan-84 14:46:45 #-h- assign 330 ascii 15-Jan-84 14:46:46 ### Assign Associate file name with specific internal specifier. integer function assign( nam, fd, access) character nam(ARB) filedes fd filedes cre8at # function(s) integer access include io assign = ERR if( 0 < fd & fd <= NNFILES ) { call close(fd) assign = cre8at( nam, access, fd, UNKAGE) } return end #-t- assign 330 ascii 15-Jan-84 14:46:46 #-h- auxfmt 3029 ascii 15-Jan-84 14:46:46 ### AuxFmt Format `auxilliary' file information into `date'. subroutine auxfmt( qdate, nam, fmt, grp, mem, prot, eof, free, typ, aux, date) integer qdate(2), grp, mem, prot, eof, free, typ integer auxndx, cnt, i, j, n, ondx, dsc(2), timlen integer ctoi, index, indexs, itoc, length # function(s) character aux(ARB), c, date(ARB), fmt(ARB), nam(ARB), temp(FILENAMESIZE) string ascstr "asc" string binstr "bin" string dirstr "dir" string objstr ".obj" ondx = 1 call fold(fmt) for( auxndx = 1 ; fmt(auxndx) != EOS ; auxndx = auxndx + 1 ) { while( fmt(auxndx) == ' ' | fmt(auxndx) == '@t' ) { call chcopy( fmt(auxndx), aux, ondx) auxndx = auxndx + 1 } cnt = ctoi( fmt, auxndx) if( cnt == 0 ) cnt = 1 c = fmt(auxndx) if( c == 'n' ) # File name. { call stcopy( nam, 1, aux, ondx) for( cnt = cnt - length(nam) ; cnt > 0 ; cnt = cnt - 1 ) call chcopy( ' ', aux, ondx) } else if( c == 'c' ) # File size in characters. { j = 512 * eof + ( free - 512 ) n = itoc( j, temp, cnt ) for( j = cnt ; j > n ; j = j - 1 ) call chcopy( ' ', aux, ondx) call stcopy( temp, 1, aux, ondx) } else if( c == 'b' ) # File size in blocks. { j = eof if( free > 0 ) j = j + 1 n = itoc( j, temp, cnt ) for( j = cnt ; j > n ; j = j - 1 ) call chcopy( ' ', aux, ondx) call stcopy( temp, 1, aux, ondx) } else if( c == 't' ) # File type (asc|bin|dir). { call strcpy( binstr, temp) if( typ == ASCII ) if( indexs( nam, objstr) == 0 ) { if( index( nam, '/') == length(nam) ) call strcpy( dirstr, temp) else call strcpy( ascstr, temp) } call stcopy( temp, 1, aux, ondx) } else if( c == 'm' ) # Modification date & time. { dsc(1) = 24 dsc(2) = %loc(temp) call sys$asctim( timlen, dsc, qdate, %val(0) ) # dd-mmm-yy hh:mm:ss:ff. j = index( temp, '.') temp(j) = EOS # Strip fractions of seconds. call stcopy( temp, 1, aux, ondx) } else if( c == 'p' ) # Protection codes. { j = 1 for( i = 1 ; i <= 16 ; i = i + 1 ) { if( mod( prot, 2) == 1 ) temp(j) = '-' else if( mod( i, 4) == 1 ) temp(j) = 'r' else if( mod( i, 4) == 2 ) temp(j) = 'w' else if( mod( i, 4) == 3 ) temp(j) = 'e' else temp(j) = 'd' if( mod( i, 4) == 0 & i < 16 ) { j = j + 1 temp(j) = '|' } prot = prot / 2 j = j + 1 } temp(j) = EOS call stcopy( temp, 6, aux, ondx) # Skip SYSTEM protection codes. } else if( c == 'o' ) # File owner's username. { call fmtuic( grp, mem, temp) call resuic( temp, date) call stcopy( date, 1, aux, ondx) for( cnt = cnt - length(date) ; cnt > 0 ; cnt = cnt - 1 ) call chcopy( ' ', aux, ondx) } else # Not a field specifier; call chcopy( c, aux, ondx) # just copy into output. } aux(ondx) = EOS call fold(aux) call srttim( qdate, date) return end #-t- auxfmt 3029 ascii 15-Jan-84 14:46:46 #-h- brdcst 498 ascii 15-Jan-84 14:46:47 ### BrdCst Broadcast a message to one or all terminals. integer function brdcst( msg, dev) character dev(ARB), msg(ARB) integer msgdsc(2), devdsc(2) integer equal, sys$brdcst # function(s) string all "ALL" if( dev(1) == EOS ) return(ERR) call dscbld( msgdsc, msg) call upper(dev) call dscbld( devdsc, dev) if( equal( all, dev) == YES ) { if( sys$brdcst( msgdsc, ) != SS_NORMAL ) return(ERR) } else { if( sys$brdcst( msgdsc, devdsc) != SS_NORMAL ) return(ERR) } return(OK) end #-t- brdcst 498 ascii 15-Jan-84 14:46:47 #-h- closdr 240 ascii 15-Jan-84 14:46:47 ### ClosDr Close directory file open on `desc'. subroutine closdr(desc) integer desc include cdirec if( 1 <= desc & desc <= NDIRECTS ) andif( dfab(desc) != 0 ) { call dclose( dfab(desc) ) dfab(desc) = 0 } return end #-t- closdr 240 ascii 15-Jan-84 14:46:47 #-h- close 436 ascii 15-Jan-84 14:46:47 ### Close Close file open on `fd'. subroutine close(fd) filedes fd include io if( 1 <= fd & fd <= NNFILES ) # Do NOTHING on bad fd. { if( lfn(fd) == NODEVICE ) return if( lastc(fd) > 0 & mode(fd) == OUTPUTMODE ) call putch( '@n', fd) # flush last line if output call closef( fdb(fd) ) if (rawchn(fd) != NODEVICE) call sys$dassgn(%val(rawchn(fd))) rawchn(fd) = NODEVICE lfn(fd) = NODEVICE } return end #-t- close 436 ascii 15-Jan-84 14:46:47 #-h- cmatch 245 ascii 15-Jan-84 14:46:48 ### CMatch Return `c' if `c' is in `array', else return(EOS). character function cmatch(c, array) character c, array(ARB) integer i for( i = 1 ; array(i) != EOS ; i = i + 1 ) if( c == array(i) ) break cmatch = array(i) return end #-t- cmatch 245 ascii 15-Jan-84 14:46:48 #-h- copyit 274 ascii 15-Jan-84 14:46:48 ### CopyIt Copy in(start) -> in(stop) into out with EOS terminator. subroutine copyit( in, start, stop, out) character in(ARB), out(ARB) integer i, j, start, stop j = 1 for( i = start ; i <= stop ; i = i + 1 ) { out(j) = in(i) j = j + 1 } out(j) = EOS return end #-t- copyit 274 ascii 15-Jan-84 14:46:48 #-h- cputim 299 ascii 15-Jan-84 14:46:48 ### CpuTim Return the CPU time used since `start'. integer function cputim(start) integer start, cpubuf, cpu integer*2 jpibuf(8) equivalence( cpubuf, jpibuf(3) ) data jpibuf / 4, JPI_CPUTIM, 6*0 / cpubuf = %loc(cpu) call sys$getjpi( , , , jpibuf, , , ) cputim = cpu - start return end #-t- cputim 299 ascii 15-Jan-84 14:46:48 #-h- cre8at 1383 ascii 15-Jan-84 14:46:49 ### Cre8At Create file `fil' attached to `fd' with access mode `access'. filedes function cre8at( fil, access, fd, age) character buf(FILENAMESIZE), fil(ARB) filedes fd filedes opena, openn, openp, openr, opens, openw # function(s) integer access, cctype, devtyp, status, age integer index # function(s) include io if( index( fil, '/') > 0 | index( fil, '\') > 0 ) call mklocl( fil, buf) else call strcpy( fil, buf) call upper(buf) # convert file name to upper case if( access == READ ) status = openr( buf, fd, access) else if( access == WRITE | access == READWRITE | access == BINARY_WRITE ) status = openw( buf, fd, access, age) # BINARY support; dpm 7-Sep-81 else if( access == APPEND ) status = opena( buf, fd, access, age) else if( access == NEWREAD ) status = openn( buf, fd, access) else if( access == SCRATCH ) status = opens( buf, fd, access) else if( access == PRINT ) status = openp( buf, fd, access) else status = ERR if( status == ERR ) cre8at = ERR else { call strcpy( buf, filenm( 1, fd) ) # variables filacc(fd) = access cre8at = fd if( status != CHARAC ) # set file type fltype(fd) = BINARY else fltype(fd) = ASCII rawchn(fd) = NODEVICE # (dpm 8-Jun-81) lfn(fd) = devtyp( fdb(fd) ) chtype(fd) = COOKED # IO is cooked by default. imp_ctrl(fd) = cctype( fdb(fd)) # (dpm 16-Jul-81) } return end #-t- cre8at 1383 ascii 15-Jan-84 14:46:49 #-h- create 409 ascii 15-Jan-84 14:46:49 ### Create Associate file `fil' with internal descriptor at mode `access'. filedes function create( fil, access) character fil(ARB) filedes fd filedes cre8at, nxtlun # function(s) integer access, newacc include io if( nxtlun(fd) == ERR ) create = ERR else { if( access == READ ) newacc = NEWREAD else newacc = access create = cre8at( fil, newacc, fd, UNKAGE) } return end #-t- create 409 ascii 15-Jan-84 14:46:49 #-h- crembx 1046 ascii 15-Jan-84 14:46:49 ### CreMbx Create a (VMS) mailbox. integer function crembx(buf, uniqit, descr, unit) character buf(ARB), unqbuf(20), name(64) integer*4 descr, status, sys$crembx, init, i, length, sys$getchn, uniqit integer lognm(2) integer*2 unit, chunit equivalence( chunit, name(13) ) data init / 0 / if( init == 0 ) { call unique(unqbuf) init = 1 } i = 1 call stcopy( buf, 1, name, i) if( uniqit == YES ) call stcopy( unqbuf, 1, name, i) name(i) = EOS call upper(name) call dscbld( lognm, name) status = sys$crembx( , # Temporary mailbox descr, # Receives channel # %val(ARGBUFSIZE), # Max message size %val(ARGBUFSIZE), # Max pool usage %val(0), # No protection , # Maximize access lognm) # Logical name string if( status != SS_NORMAL & status != SS_SUPERCEDE ) crembx = ERR else { call scopy( name, 1, buf, 1) lognm(1) = 64 status = sys$getchn( %val(descr), , lognm, , ) if( status != SS_NORMAL & status != SS_BUFFEROVF ) crembx = ERR else { unit = chunit crembx = OK } } return end #-t- crembx 1046 ascii 15-Jan-84 14:46:49 #-h- ctoptr 197 ascii 15-Jan-84 14:46:50 ### CToPtr Convert character string to pointer. subroutine ctoptr( buf, i, ptr) character buf(ARB) integer i, ptr(2) integer ctoi ptr(1) = ctoi( buf, i) ptr(2) = ctoi( buf, i) return end #-t- ctoptr 197 ascii 15-Jan-84 14:46:50 #-h- cvtdtop 1263 ascii 15-Jan-84 14:46:50 ### CvtDToP Convert DEC filespec to pathname. # # correspondences # # string:: -> /@string # string: -> /string # [string...] -> /string[/...] # [.string...] -> string[/...] # string -> string # # in addition, if the user types [a.b.c]xyz with no device name, the # current default device will be inserted # subroutine cvt_dtop( in, out) character in(FILENAMESIZE), out(FILENAMESIZE), host(FILENAMESIZE) character device(FILENAMESIZE), direct(FILENAMESIZE), file(FILENAMESIZE) character temp(FILENAMESIZE) integer i string slat "/@@" call scopy( in, 1, out, 1) call upper(out) call explog( out, temp) call parsef( temp, host, device, direct, file) i = 1 if( host(1) != EOS ) { call stcopy( slat, 1, out, i) call stcopy( host, 1, out, i) } if( device(1) != EOS ) { call chcopy( '/', out, i) call stcopy( device, 1, out, i) } if( direct(1) != EOS ) { if( direct(2) == '.' ) # permit [.x] call dirout( direct, out, i) else { if( device(1) == EOS ) { call chcopy( '/', out, i) call gtddev(device) call stcopy( device, 1, out, i) } call dirout( direct, out, i) } } if (i > 1) call chcopy('/', out, i) if( file(1) != EOS ) { call stcopy( file, 1, out, i) } out(i) = EOS call fold(out) return end #-t- cvtdtop 1263 ascii 15-Jan-84 14:46:50 #-h- cwdir 333 ascii 15-Jan-84 14:46:51 ### CWDir Change working directory to `dir'. integer function cwdir(dir) character dir(FILENAMESIZE), path(FILENAMESIZE) integer desc integer opendr # function(s) call mkpath( dir, path) if( opendr( path, desc) != ERR ) # directory exists { call closdr(desc) call stdpth(path) return(OK) } else return(ERR) end #-t- cwdir 333 ascii 15-Jan-84 14:46:51 #-h- dclout 680 ascii 15-Jan-84 14:46:51 integer function dclout(lin, start, stop, args) character lin(ARB), args(ARB), qchar integer i, j, start, stop, junk integer getwrd for( i = 1 ; lin(i) != '@n' & lin(i) != EOS ; i = i + 1 ) { if( lin(i) == ' ' ) { call skipbl( lin, i) if( lin(i) == '>' ) { start = i - 1 for( ; lin(i) == '>' ; i = i + 1 ) ; junk = getwrd( lin, i, args) stop = i return(YES) } i = i - 1 } else if( lin(i) == '@'' | lin(i) == '"' ) { qchar = lin(i) repeat i = i + 1 until( lin(i) == qchar | lin(i) == '@n' | lin(i) == EOS ) if( lin(i) != qchar ) i = i - 1 } } return(NO) end #-t- dclout 680 ascii 15-Jan-84 14:46:51 #-h- defdir 264 ascii 15-Jan-84 14:46:51 ### DefDir Return the DEC form of the current working directory [...] subroutine defdir(direct) integer dsc(2) character direct(ARB) dsc(1) = 64 dsc(2) = %loc(direct) call sys$setddir( , dsc, dsc(1) ) direct( dsc(1) + 1 ) = EOS call fold(direct) return end #-t- defdir 264 ascii 15-Jan-84 14:46:51 #-h- delarg 306 ascii 15-Jan-84 14:46:52 ### DelArg Delete reference to command line argument `n'. # See comments in GetArg for how the arguments are stored. subroutine delarg(n) integer i, n include carg if( 0 <= n & n < nbrarg ) { for( i = n + 1 ; i < nbrarg ; i = i + 1 ) ptr(i) = ptr( i + 1 ) nbrarg = nbrarg - 1 } return end #-t- delarg 306 ascii 15-Jan-84 14:46:52 #-h- dirfil 1395 ascii 15-Jan-84 14:46:52 ### DirFil Generate directory filespec from pathname subroutine dirfil( dpath, file, direc) character dpath(ARB), file(ARB), node(FILENAMESIZE) character device(FILENAMESIZE), temp(FILENAMESIZE), dnode(FILENAMESIZE) character direc(ARB), direct(FILENAMESIZE) integer i, junk, gtftok, depth, ptr(10), j, k, equal string rootdr "[000000]" # (dpm 10-Jun-81) i = 2 junk = gtftok( dpath, i, node) if( node(1) == '@@' ) { call scopy( node, 2, node, 1) junk = gtftok( dpath, i, device) j = 3 } else { call strcpy( node, device) node(1) = EOS j = 2 } call exppth( dpath, depth, ptr, temp) if( depth == j ) call strcpy( rootdr, direct) else { direct(1) = '[' k = 2 for( ; j < depth ; j = j + 1 ) { junk = gtftok( dpath, i, temp) call stcopy( temp, 1, direct, k) direct(k) = '.' k = k + 1 } direct( k - 1 ) = ']' direct(k) = EOS } junk = gtftok( dpath, i, temp) j = length(temp) + 1 call scopy( ".dir", 1, temp, j) call hostnm(dnode) if( equal( dnode, node) == YES ) node(1) = EOS call fgenr8( node, device, direct, temp, file) call upper(file) if( equal( direct, rootdr) == YES ) j = 2 else { j = index( direct, ']') direct(j) = '.' j = j + 1 } for( k = 1 ; temp(k) != '.' ; k = k + 1 ) { direct(j) = temp(k) j = j + 1 } direct(j) = ']' direct( j + 1 ) = EOS call fgenr8( node, device, direct, EOS, direc) call upper(direc) return end #-t- dirfil 1395 ascii 15-Jan-84 14:46:52 #-h- dirout 573 ascii 15-Jan-84 14:46:52 ### DirOut Convert DEC directory string to path format, incrementing i. subroutine dirout( direct, out, i) character direct(ARB), out(ARB) integer i, j if( direct(1) != '[' ) return if( direct(2) == '.' ) j = 3 else { call chcopy( '/', out, i) j = 2 } while( direct(j) != ']' ) { if( direct(j) == '.' ) { call chcopy( '/', out, i) j = j + 1 } for( ; direct(j) != '.' & direct(j) != ']' ; j = j + 1 ) { if( direct(j) == EOS ) { out(i) = EOS return } call chcopy( direct(j), out, i) } } out(i) = EOS return end #-t- dirout 573 ascii 15-Jan-84 14:46:52 #-h- dscbld 198 ascii 15-Jan-84 14:46:53 ### DscBld Build a VAX descriptor for `string' in `dsc'. subroutine dscbld( dsc, string) integer dsc(2), length character string(ARB) dsc(1) = length(string) dsc(2) = %loc(string) return end #-t- dscbld 198 ascii 15-Jan-84 14:46:53 #-h- enbint 704 ascii 15-Jan-84 14:46:53 ### EnbInt Enable ^C interrupts for process. subroutine enbint character buf(FILENAMESIZE) integer chan, init, intok, mypid, ownid integer isatty, rtopen, sys$qiow # function(s) external intsrv data init / YES / if( init == YES ) { call getpid(mypid) call getown( mypid, ownid) init = NO if( isatty(STDIN) == YES & ownid == 0 ) intok = YES else intok = NO if( intok == YES ) { if( rtopen( "TT", chan) == ERR ) { intok = NO call remark( "Cannot assign channel for interrupts" ) } } } if( intok == YES ) { if( .not.sys$qiow( , %val(chan), %val( IO_CTRLCAST ),,,, intsrv,,,,, ) ) call error( "Cannot enable ^C interrupt" ) } return end #-t- enbint 704 ascii 15-Jan-84 14:46:53 #-h- endst 326 ascii 15-Jan-84 14:46:53 ### EndST Close all files and exit with `status'. subroutine endst(status) filedes fd integer status, exit_stat include io for( fd = 1 ; fd <= NNFILES ; fd = fd + 1 ) call close(fd) if( status == OK ) exit_stat = 1 else exit_stat = CHILD_ABORTED call sys$exit( %val( exit_stat ) ) # Exit with status. end #-t- endst 326 ascii 15-Jan-84 14:46:53 #-h- exetim 604 ascii 15-Jan-84 14:46:54 ### ExeTim Return execution time accumulated since `start'. integer function exetim(start) integer start, time, login(2), logbuf, init integer*2 timb(7), jpibuf(8), logtim(7) equivalence( logbuf, jpibuf(3) ) data jpibuf / 8, JPI_LOGINTIM, 6*0 / data init / YES / if( init == YES ) { logbuf = %loc(login) call sys$getjpi( , , , jpibuf, , , ) call sys$numtim( logtim, login) init = NO } call sys$numtim( timb, ) time = timb(4) - logtim(4) time = 60 * time + timb(5) - logtim(5) time = 60 * time + timb(6) - logtim(6) time = 100 * time + timb(7) - logtim(7) return( time - start ) end #-t- exetim 604 ascii 15-Jan-84 14:46:54 #-h- exith 293 ascii 15-Jan-84 14:46:54 ### ExitH VAX/VMS exit handler to clean up BYTLM for mailboxes. # This may not be necessary in future releases of VMS. subroutine exith include ctrmbx include cexith call sys$dassgn( %val(termbx) ) # Deassign channel to termination # mail-box to release bytlm quota. return end #-t- exith 293 ascii 15-Jan-84 14:46:54 #-h- explog 626 ascii 15-Jan-84 14:46:54 ### ExpLog Iteratively resolve all logical names in file spec. subroutine explog( in, out) character in(ARB), out(ARB) character node(FILENAMESIZE), device(FILENAMESIZE), direct(FILENAMESIZE) character file(FILENAMESIZE), temp(FILENAMESIZE), nnode(FILENAMESIZE) character ndev(FILENAMESIZE) integer trans, tran1 call strcpy( in, temp) repeat { trans = NO call parsef( temp, node, device, direct, file) if( tran1( node, nnode) == YES ) trans = YES if( tran1( device, ndev) == YES ) trans = YES call fgenr8( nnode, ndev, direct, file, temp) } until( trans == NO ) call strcpy( temp, out) return end #-t- explog 626 ascii 15-Jan-84 14:46:54 #-h- exppid 168 ascii 15-Jan-84 14:46:55 ### ExpPid You figure it out. subroutine exppid( in, out) character in(PIDSIZE), out(PIDSIZE) integer pid, htoi pid = htoi(in) call puthex( pid, out) return end #-t- exppid 168 ascii 15-Jan-84 14:46:55 #-h- fgenr8 677 ascii 15-Jan-84 14:46:55 ### FGenr8 Generate DEC file spec given node, device, dir, and file string. subroutine fgenr8( node, device, direct, file, out) character node(ARB), device(ARB), direct(ARB), file(ARB), out(ARB) integer i integer index, indexs string rbrlbr "][" i = 1 if( node(1) != EOS ) { call stcopy( node, 1, out, i) call stcopy( "::", 1, out, i) } if( device(1) != EOS ) { call stcopy( device, 1, out, i) if( index( device, ':') == 0 ) call chcopy( ':', out, i) } call stcopy( direct, 1, out, i) call scopy( file, 1, out, i) i = indexs(out, rbrlbr) # see if ][ in string if (i > 0) # yes, have v3 goody call scopy(out, i+2, out, i) # remove it return end #-t- fgenr8 677 ascii 15-Jan-84 14:46:55 #-h- filnfo 327 ascii 15-Jan-84 14:46:55 ### FilNfo Get name and access mode of file open on fd. integer function filnfo( fd, name, access) integer fd, access character name(ARB) include io if( 1 <= fd & fd <= NNFILES ) andif( lfn(fd) != NODEVICE ) { call strcpy( filenm( 1, fd), name) access = filacc(fd) return(OK) } return(ERR) end #-t- filnfo 327 ascii 15-Jan-84 14:46:55 #-h- flfind 390 ascii 15-Jan-84 14:46:56 ### FlFind Find file and retrieve its LOCAL filename and type. integer function flfind( infil, outfil, type) character infil(FILENAMESIZE), outfil(FILENAMESIZE) filedes fd integer type integer open, gettyp # function(s) fd = open( infil, READ) if( fd != ERR ) { type = gettyp( fd, type) call close(fd) call mklocl( infil, outfil) call fold(outfil) } return(fd) end #-t- flfind 390 ascii 15-Jan-84 14:46:56 #-h- fmttim 994 ascii 15-Jan-84 14:46:56 ### FmtTim Format time into `buf'. integer function fmttim( string, intime, buf) integer time(4), n, itoc, j, k, intime character buf(ARB), string(ARB), temp(5) time(3) = intime / 100 time(4) = intime - 100 * time(3) time(2) = time(3) / 60 time(3) = time(3) - 60 * time(2) time(1) = time(2) / 60 time(2) = time(2) - 60 * time(1) j = 1 call stcopy( string, 1, buf, j) n = 4 - itoc( time(1), temp, 5) for( k = 1 ; k <= n ; k = k + 1 ) { buf(j) = ' ' j = j + 1 } call stcopy( temp, 1, buf, j) buf(j) = ':' j = j + 1 n = 2 - itoc( time(2), temp, 3) for( k = 1 ; k <= n ; k = k + 1 ) { buf(j) = '0' j = j + 1 } call stcopy( temp, 1, buf, j) buf(j) = ':' j = j + 1 n = 2 - itoc( time(3), temp, 3) for( k = 1 ; k <= n ; k = k + 1 ) { buf(j) = '0' j = j + 1 } call stcopy( temp, 1, buf, j) buf(j) = '.' j = j + 1 n = 2 - itoc( time(4), temp, 3) for( k = 1 ; k <= n ; k = k + 1 ) { buf(j) = '0' j = j + 1 } call stcopy( temp, 1, buf, j) buf(j) = EOS fmttim = j - 1 return end #-t- fmttim 994 ascii 15-Jan-84 14:46:56 #-h- fmtuic 345 ascii 15-Jan-84 14:46:56 ### FmtUIC Format UIC of `grp', `mem' into `uic' as `[ggg,mmm]'. subroutine fmtuic( grp, mem, uic) integer*2 grp, mem integer ctstr(2), outdsc(2) character uic(ARB) string cstrng "[!OB,!OB]" call dscbld( ctstr, cstrng) outdsc(1) = 10 outdsc(2) = %loc(uic) call sys$fao( ctstr, , outdsc, %val(grp), %val(mem) ) uic(10) = EOS return end #-t- fmtuic 345 ascii 15-Jan-84 14:46:56 #-h- gdraux 1200 ascii 15-Jan-84 14:46:57 ### GDrAux Get `auxilliary' (system-dependent) info about file. subroutine gdraux( desc, file, aux, date, fmt) integer desc, qdate(2), grp, mem, prot, eof, free, i, ftype integer decnfo, index, length # function(s) character file(ARB), aux(ARB), date(ARB), fmt(ARB), temp(FILENAMESIZE) include cdirec string cantrd "? Can't read information for file ``" string qqdot "''" string dot1 ".1" string dotdot1 "..1" string dotdir ".dir" i = 1 # Build error message string call stcopy( cantrd, 1, aux, i) call stcopy( file, 1, aux, i) call scopy( qqdot, 1, aux, i) for( i = 1 ; i <= TCOLWIDTH ; i = i + 1 ) date(i) = ' ' date(i) = EOS if( desc < 1 | desc > NDIRECTS ) return if( dfab(desc) == 0 ) return call concat( dnam( 1, desc), file, temp) i = index( file, '.') + 1 if( i == 1 ) { i = index( file, '/') if( i == 0 ) call concat( temp, dotdot1, temp) else { i = length(temp) temp(i) = EOS call concat( temp, dotdir, temp) } } else if( index( file(i), '.') == 0 ) call concat( temp, dot1, temp) if( decnfo( temp, qdate, grp, mem, prot, eof, free, ftype) != ERR ) call auxfmt( qdate, file, fmt, grp, mem, prot, eof, free, ftype, aux, date) return end #-t- gdraux 1200 ascii 15-Jan-84 14:46:57 #-h- gdrprm 1261 ascii 15-Jan-84 14:46:57 ### GDrPrm Get `primary' info (filename) of next entry in directory. integer function gdrprm( desc, file) character file(FILENAMESIZE), temp(4) integer i, desc, j, k integer index, dfind, equal string dir "dir" include cdirec repeat { if( desc < 1 | desc > NDIRECTS ) gdrprm = EOF else if( dfab(desc) == 0 ) gdrprm = EOF else if( dfind( dfab(desc), file) == EOF ) gdrprm = EOF else { i = index( file, ']') + 1 if( i == 1 ) i = index( file, ':') + 1 call scopy( file, i, file, 1) call fold(file) if( equal( file, lfile( 1, desc) ) == YES ) return(EOF) # seen this file on magtape before call scopy( file, 1, lfile( 1, desc), 1) # update last file seen i = index( file, ';') file(i) = '.' i = length(file) if( file(i) == '1' & file( i - 1 ) == '.' ) file( i - 1 ) = EOS k = index( file, '.') i = k + 1 for( j = 1 ; j < 4 ; j = j + 1 ) { temp(j) = file(i) i = i + 1 } temp(j) = EOS if( equal( temp, dir) == YES ) call chcopy( '/', file, k) else if( temp(1) == EOS ) file(k) = EOS if( equal( file, "000000/" ) == YES ) gdrprm = ERR else gdrprm = OK } } until( gdrprm != ERR ) return end #-t- gdrprm 1261 ascii 15-Jan-84 14:46:57 #-h- gendir 852 ascii 15-Jan-84 14:46:57 ### GenDir Generate DEC directory spec from full pathname. subroutine gendir( path, out) integer i, junk, j, k integer gtftok # function(s) character path(ARB), out(ARB), node(FILENAMESIZE), device(FILENAMESIZE) character direct(FILENAMESIZE), temp(FILENAMESIZE) string null "" string zz "000000" # (dpm 10-Jun-81) i = 2 junk = gtftok( path, i, device) if( device(1) == '@@' ) { call scopy( device, 2, node, 1) junk = gtftok( path, i, device) } else node(1) = EOS j = 1 call chcopy( '[', direct, j) while( gtftok( path, i, temp) > 0 ) { if( j > 2 ) call chcopy( '.', direct, j) if( temp(1) == '%' ) # Don't pass anchor character k = 2 else k = 1 call stcopy( temp, k, direct, j) } if( j == 2 ) call stcopy( zz, 1, direct, j) call chcopy( ']', direct, j) call fgenr8( node, device, direct, null, out) return end #-t- gendir 852 ascii 15-Jan-84 14:46:57 #-h- genpnm 1117 ascii 15-Jan-84 14:46:58 ### GenPNm Generate subprocess name. subroutine genpnm( proces, wait, offset) character wait, base(20), level(4), c, proces(ARB) character type integer n, i, j, junk integer index, ctoi, itoc, length # function(s) string l1 ".1" call getpnm(proces) # get this process's name if( proces(1) == '$' ) # spawned by a tool? { n = index( proces, '.') # find separator if( n > 0 ) { i = n + 1 j = ctoi( proces, i) + 1 level(1) = '.' junk = itoc( j, level(2), 3) proces(n) = EOS } else call strcpy( l1, level) call strcpy( proces, base) } else { base(1) = '$' j = 2 for( i = 1 ; proces(i) != EOS ; i = i + 1 ) { c = type( proces(i) ) if( c == LETTER | c == DIGIT ) { base(j) = proces(i) j = j + 1 } } base(j) = EOS n = length(base) if( n > 8 ) # must truncate to 8 unique characters call scopy( base, n - 6, base, 2) call strcpy( l1, level) } i = 1 call stcopy( base, 1, proces, i) if( wait == BACKGR ) { call chcopy( '&', proces, i) junk = itoc( offset, proces(i), 3) } else call scopy( level, 1, proces, i) return end #-t- genpnm 1117 ascii 15-Jan-84 14:46:58 #-h- getarg 578 ascii 15-Jan-84 14:46:58 ### GetArg Get specified command line argument. # arguments 0 -> nbrarg-1 are pointed to by ptr(1) -> ptr(nbrarg) # argument 0 is the name by which the utility was invoked integer function getarg( n, array, maxsiz) character array(ARB) integer n, maxsiz include carg if( n >= nbrarg ) # no argument n { array(1) = EOS getarg = EOF return } j = ptr( n + 1 ) if( arg(j) == '@'' | arg(j) == '"' ) j = j + 1 for( i = 1 ; i <= maxsiz ; i = i + 1 ) { array(i) = arg(j) if( arg(j) == EOS ) break j = j + 1 } getarg = i - 1 array(i) = EOS return end #-t- getarg 578 ascii 15-Jan-84 14:46:58 #-h- getast 147 ascii 15-Jan-84 14:46:59 ### GetAST Read the value of the AST-received flag. integer function getast(value) integer value include cast value = gotast return(gotast) end #-t- getast 147 ascii 15-Jan-84 14:46:59 #-h- getbpr 191 ascii 15-Jan-84 14:46:59 ### GetBPr Get base priority of current process. subroutine getbpr(prio) integer prio jpilst(list) data list/4, JPI_PRIB, 6*0/ lista = %loc(prio) call sys$getjpi(,,,list,,,) return end #-t- getbpr 191 ascii 15-Jan-84 14:46:59 #-h- getch 835 ascii 15-Jan-84 14:46:59 ### GetCh Get characters from file open on `fd'. character function getch(c, fd) include io character c character rgetch # function(s) filedes fd integer n, count integer gets, inmap # function(s) chstat(fd) = OK # (dpm 8-Jun-81) if( chtype(fd) != COOKED ) { getch = rgetch( c, fd) # changed channel argument (dpm 8-Jun-81) return } if( mode(fd) != INPUTMODE ) { lastc(fd) = 0 bcount(fd) = 0 mode(fd) = INPUTMODE } if( lastc(fd) >= bcount(fd) | lastc(fd) >= MAXLINE ) { count = gets( fdb(fd), buffer( 1, fd), MAXCARD) if( count < 0 ) { c = EOF chstat(fd) = EOF # (dpm 8-Jun-81) return(c) } if( imp_ctrl(fd) > 0 ) { count = count + 1 buffer( count, fd) = '@n' } bcount(fd) = count lastc(fd) = 0 } lastc(fd) = lastc(fd) + 1 n = lastc(fd) c = buffer( n, fd) return(c) end #-t- getch 835 ascii 15-Jan-84 14:46:59 #-h- getdcl 314 ascii 15-Jan-84 14:47:00 ### GetDCL Get command line from DCL. integer function getdcl(lin) character lin(ARGBUFSIZE) integer desc(2), strlen, status integer lib$get_foreign desc(1) = ARGBUFSIZE - 3 # Leave room for "* " and EOS. desc(2) = %loc(lin) status = lib$get_foreign( desc, , strlen) lin(strlen+1) = EOS return(strlen) end #-t- getdcl 314 ascii 15-Jan-84 14:47:00 #-h- getdir 1145 ascii 15-Jan-84 14:47:00 ### GetDir Get `known' directory name in LOCAL or PATH format. subroutine getdir( key, type, buf) integer junk, key, type integer trnlog # function(s) character buf(ARB), temp(FILENAMESIZE) string st_bin "ST_BIN" string st_usr "ST_USR" string st_tmp "ST_TMP" string st_lpr "ST_LPR" string st_msg "ST_MSG" string st_src "ST_SRC" string st_man "ST_MAN" string st_inc "ST_INC" string st_lib "ST_LIB" if( key == BINDIRECTORY ) junk = trnlog( st_bin, temp) else if( key == USRDIRECTORY ) junk = trnlog( st_usr, temp) else if( key == TMPDIRECTORY ) junk = trnlog( st_tmp, temp) else if( key == LPRDIRECTORY ) junk = trnlog( st_lpr, temp) else if( key == MSGDIRECTORY ) junk = trnlog( st_msg, temp) else if( key == MANDIRECTORY ) junk = trnlog( st_man, temp) else if( key == SRCDIRECTORY ) # (dpm 8-Jun-81) junk = trnlog( st_src, temp) else if( key == INCDIRECTORY ) # (dpm 24-Sep-81) junk = trnlog( st_inc, temp) else if( key == LIBDIRECTORY ) # (dpm 24-Sep-81) junk = trnlog( st_lib, temp) else temp(1) = EOS call fold(temp) if( type == PATH ) { call cvt_dtop( temp, buf) } else call strcpy( temp, buf) return end #-t- getdir 1145 ascii 15-Jan-84 14:47:00 #-h- getfdb 194 ascii 15-Jan-84 14:47:00 ### GetFDB Get the "file descriptor block" for file descriptor "fd". integer function getfdb(fd) filedes fd include io if( 1 <= fd & fd <= NNFILES ) return(fdb(fd)) else return(ERR) end #-t- getfdb 194 ascii 15-Jan-84 14:47:00 #-h- getimg 427 ascii 15-Jan-84 14:47:01 ### GetImg Get the image name the current process is executing. subroutine getimg(image) character image(ARB), local(FILENAMESIZE) integer*2 jpibuf(8), length integer addr, leng equivalence (addr,jpibuf(3)), (leng, jpibuf(5)) data jpibuf /FILENAMESIZE, JPI_IMAGNAME, 6*0/ addr = %loc(local) leng = %loc(length) call sys$getjpi(,,,jpibuf,,,) local(length+1) = EOS call fold(local) call scopy(local, 1, image, 1) return end #-t- getimg 427 ascii 15-Jan-84 14:47:01 #-h- getlin 1110 ascii 15-Jan-84 14:47:01 ### GetLin Get line `line' from file open on `fd'. integer function getlin(line, fd) character line(ARB) filedes fd integer i integer gets # function(s) character getch # function(s) include io if( lastc(fd) != 0 & chtype(fd) == COOKED ) # GetCh's done on line. { for( i = 1 ; ; i = i + 1 ) { if( getch( line(i), fd) == '@n' ) { line( i + 1 ) = EOS getlin = i return } if( line(i) == EOF ) { getlin = EOF line(i) = EOS chstat(fd) = EOF # (dpm 8-Jun-81) return } if( i >= MAXLINE - 1 ) { line( i + 1 ) = EOS getlin = i return } } } else # get a record directly { if( mode(fd) != INPUTMODE ) mode(fd) = INPUTMODE lastc(fd) = 0 bcount(fd) = 0 i = gets( fdb(fd), line, MAXCARD) if( i < 0 ) { line(1) = EOS getlin = EOF chstat(fd) = EOF } else if( i < MAXCARD ) { if( imp_ctrl(fd) > 0 ) { i = i + 1 line(i) = '@n' } line( i + 1 ) = EOS getlin = i } else { line(MAXLINE) = EOS getlin = MAXCARD } } return end #-t- getlin 1110 ascii 15-Jan-84 14:47:01 #-h- getmsg 1153 ascii 15-Jan-84 14:47:02 ### GetMsg Get the command line from the shell or local CLI. integer function getmsg(buf) filedes fd integer done, i, junk, len integer equal, getdcl, getlin, length, open, trnlog # function(s) character buf(ARGBUFSIZE), pname(20), bname(20), lin(MAXLINE) string dummy "* " string dcltools "DCL_TOOLS" data done / NO / if( done == YES ) { call strcpy( dummy, buf) return( length(buf) ) } done = YES call getpnm(pname) # get our process name junk = trnlog( dcltools, buf) # see if invoked from DCL if( pname(1) != '$' | equal( dcltools, buf) == NO ) { call getimg(lin) i = index(lin, ']') + 1 call scopy(lin, i, buf, 1) i = index(buf, '.') call chcopy(' ', buf, i) junk = getdcl( buf(i) ) } else { call arggen( pname, bname) # generate mailbox name fd = open( bname, READ) # open for reading if( fd == ERR ) call strcpy( dummy, buf) else { # i = 1 # repeat # { # len = getlin( lin, fd) # if( ( len + i ) <= ARGBUFSIZE ) # call stcopy( lin, 1, buf, i) # } # until( len < MAXCARD ) i = getlin( buf, fd) call close(fd) buf(i) = EOS } } return( length(buf) ) end #-t- getmsg 1153 ascii 15-Jan-84 14:47:02 #-h- getnow 230 ascii 15-Jan-84 14:47:02 ### GetNow Get the current time (as an array of integer values) into `now'. subroutine getnow(now) integer i, now(7) integer*2 word(7) call sys$numtim( word, ) for( i = 1 ; i <= 7 ; i = i + 1 ) now(i) = word(i) return end #-t- getnow 230 ascii 15-Jan-84 14:47:02 #-h- getown 231 ascii 15-Jan-84 14:47:02 ### GetOwn Get the PID of this process' owner. subroutine getown( mypid, ownid) integer mypid, ownid jpilst(owner) data owner / 4, JPI_OWNER, 6*0 / ownera = %loc(ownid) call sys$getjpi( , mypid, , owner, , , ) return end #-t- getown 231 ascii 15-Jan-84 14:47:02 #-h- getpdb 698 ascii 15-Jan-84 14:47:03 ### GetPdb See if specified PDB exists. integer function getpdb( offset, wait) integer offset, start, stop, init, mypid, ownpid character wait include cproc data init / YES / if( init == YES ) { call getpid(mypid) call getown( mypid, ownpid) init = NO } if( wait == BACKGR ) { start = NFOREGROUND + 1 if( ownpid == 0 ) stop = NPROCESSES else stop = start - 1 } else { start = 1 stop = NFOREGROUND } call sys$setast( %val(0) ) # disable AST delivery for( offset = start ; offset <= stop & pid( 1, offset) != EOS ; offset = offset + 1 ) ; call sys$setast( %val(1) ) # enable AST delivery if( offset <= stop ) return(OK) else return(ERR) end #-t- getpdb 698 ascii 15-Jan-84 14:47:03 #-h- getpid 199 ascii 15-Jan-84 14:47:03 ### GetPID Get the PID of the current process. subroutine getpid(pid) integer pid jpilst(list) data list / 4, JPI_PID, 6*0 / lista = %loc(pid) call sys$getjpi( , , , list, , , ) return end #-t- getpid 199 ascii 15-Jan-84 14:47:03 #-h- getpnm 412 ascii 15-Jan-84 14:47:03 ### GetPNm Get the name of the current process. subroutine getpnm(proces) character proces(ARB), local(16) integer*2 jpibuf(8), length integer addr, leng equivalence( addr, jpibuf(3) ), ( leng, jpibuf(5) ) data jpibuf / 15, JPI_PRCNAM, 6*0 / addr = %loc(local) leng = %loc(length) call sys$getjpi( , , , jpibuf, , , ) local( length + 1 ) = EOS call fold(local) call strcpy( local, proces) return end #-t- getpnm 412 ascii 15-Jan-84 14:47:03 #-h- getprv 368 ascii 15-Jan-84 14:47:04 ### GetPrv Get the privileges the current process is authorized to pass on. subroutine getprv(priv) integer priv(2), junk integer sys$getjpi jpilst(list) data list / 8, JPI_PROCPRIV, 6*0 / lista = %loc(priv) list(2) = JPI_PROCPRIV if (.not. sys$getjpi( , , , list, , , )) { list(2) = JPI_AUTHPRIV junk = sys$getjpi( , , , list, , , ) } return end #-t- getprv 368 ascii 15-Jan-84 14:47:04 #-h- getrln 404 ascii 15-Jan-84 14:47:04 ### GetRLn Get an unCOOKED line of input into `buf'. character function getrln( buf, fd, trmara) character buf(ARB), c, trmara(ARB), trmn8r character cmatch, getch # function(s) filedes fd integer i for( i = 1 ; i < MAXLINE ; i = i + 1 ) { c = getch( buf(i), fd) trmn8r = cmatch( c, trmara) if( trmn8r != EOS ) break else call putch( c, fd) } buf(i) = EOS return(trmn8r) end #-t- getrln 404 ascii 15-Jan-84 14:47:04 #-h- gettyp 183 ascii 15-Jan-84 14:47:04 ### GetTyp Return type (ASCII or BINARY) of file open on `fd'. integer function gettyp( fd, type) filedes fd integer type include io type = fltype(fd) return(type) end #-t- gettyp 183 ascii 15-Jan-84 14:47:04 #-h- getuic 246 ascii 15-Jan-84 14:47:05 ### GetUIC Get the UIC of the current process. subroutine getuic(uic) integer*4 uic, uica integer*2 jpibuf(8) equivalence( jpibuf(3), uica) data jpibuf / 4, JPI_UIC, 6*0 / uica = %loc(uic) call sys$getjpi( , , , jpibuf, , , ) return end #-t- getuic 246 ascii 15-Jan-84 14:47:05 #-h- gtddev 255 ascii 15-Jan-84 14:47:05 ### GtDDev Get name of default device (without ':'). subroutine gtddev(device) character device(ARB), scrat(FILENAMESIZE), temp(FILENAMESIZE) call explog( "SYS$DISK:", scrat) call parsef( scrat, temp, device, temp, temp) call fold(device) return end #-t- gtddev 255 ascii 15-Jan-84 14:47:05 #-h- gtdflt 641 ascii 15-Jan-84 14:47:05 ### GtDflt Get default node, device and directory in LOCAL format. # The node and device will not have colons appended, while the # directory will be of the form `[a{.a}...]'. subroutine gtdflt( node, device, direct) character node(ARB), device(ARB), direct(ARB), temp(FILENAMESIZE) integer i integer index call defdir(direct) call explog( "SYS$DISK:", temp) i = index(temp, ']') if (i > 0) # have a v3 goody call scopy(direct, 2, temp, i) else call concat(temp, direct, temp) call parsef( temp, node, device, direct, temp) if( node(1) == EOS ) call hostnm(node) call fold(node) call fold(device) call fold(direct) return end #-t- gtdflt 641 ascii 15-Jan-84 14:47:05 #-h- gtdpth 550 ascii 15-Jan-84 14:47:06 ### GtDPth Get the current working directory name in PATH format. subroutine gtdpth(dir) character device(FILENAMESIZE), direct(FILENAMESIZE) character host(FILENAMESIZE), dir(ARB) integer i, j call gtdflt( host, device, direct) dir(1) = '/' dir(2) = '@@' j = 3 call stcopy( host, 1, dir, j) dir(j) = '/' j = j + 1 call stcopy( device, 1, dir, j) for( i = 1 ; direct(i) != ']' & direct(i) != EOS ; i = i + 1 ) { if( direct(i) == '[' | direct(i) == '.' ) dir(j) = '/' else dir(j) = direct(i) j = j + 1 } dir(j) = EOS return end #-t- gtdpth 550 ascii 15-Jan-84 14:47:06 #-h- gtmode 231 ascii 15-Jan-84 14:47:06 ### GtMode Return the I/O mode {COOKED|RARE|RAW} of filedes "fd". integer function gtmode(fd) filedes fd include io if( 1 <= fd & fd <= NNFILES ) andif( lfn(fd) != NODEVICE ) return( chtype(fd) ) return(ERR) end #-t- gtmode 231 ascii 15-Jan-84 14:47:06 #-h- gtstat 177 ascii 15-Jan-84 14:47:06 ### GtStat Return status on io channel `fd'. integer function gtstat( fd) include io filedes fd if( 1 <= fd & fd <= NNFILES ) return( chstat( fd)) else return(ERR) end #-t- gtstat 177 ascii 15-Jan-84 14:47:06 #-h- gtzone 351 ascii 15-Jan-84 14:47:07 subroutine gtzone(buf) character buf(ARB), temp(FILENAMESIZE) integer equal, dstime integer now(7) string seed "ST_TIMEZONE" call trnlog(seed, temp) if (equal(seed, temp) == YES) buf(1) = 'P' else buf(1) = temp(1) call getnow(now) if (dstime(now) == YES) buf(2) = 'D' else buf(2) = 'S' buf(3) = 'T' buf(4) = EOS call upper(buf) return end #-t- gtzone 351 ascii 15-Jan-84 14:47:07 #-h- gwdir 300 ascii 15-Jan-84 14:47:08 ### GWDir Get the name of the current working directory in LOCAL format. subroutine gwdir( buf, dtype) character buf(ARB), temp(FILENAMESIZE) integer dtype call gtdpth(temp) call concat(temp, "/", temp) if( dtype == LOCAL ) call mklocl( temp, buf) else call mkpath( temp, buf) return end #-t- gwdir 300 ascii 15-Jan-84 14:47:08 #-h- homdir 888 ascii 15-Jan-84 14:47:08 ### HomDir Get the name of our home directory. subroutine homdir(home, dtype) character sender(USERSIZE), home(ARB), buf(MAXLINE) character usrfil(FILENAMESIZE) integer junk, i, found, dtype integer openf, n, gets, rab, index integer equal, getwrd # function(s) call mailid(sender) # get mailid i = index( sender, ' ') if( i > 0 ) sender(i) = EOS found = NO call adrfil(usrfil) call upper(usrfil) if (openf(usrfil, 0, 0, READ, -1, rab) != ERR) { repeat { n = gets(rab, buf, MAXCARD) if (n < 0) break buf(n+1) = EOS i = 1 junk = getwrd(buf, i, home) if (equal(home, sender) == YES) { junk = getwrd(buf, i, usrfil) found = YES break } } call closef(rab) } if (found == NO) home(1) = EOS else if (dtype == LOCAL) call strcpy(usrfil, home) else call cvt_dtop(usrfil, home) call fold(home) return end #-t- homdir 888 ascii 15-Jan-84 14:47:08 #-h- hostnm 188 ascii 15-Jan-84 14:47:09 ### HostNm Get name of current host. subroutine hostnm(tstr) character tstr integer junk integer trnlog # function(s) junk = trnlog( "ST_NODE", tstr) call fold(tstr) return end #-t- hostnm 188 ascii 15-Jan-84 14:47:09 #-h- htoi 327 ascii 15-Jan-84 14:47:09 ### HToI Return value of hex string contained in `buf'. integer function htoi(buf) character buf(ARB), temp(PIDSIZE) integer n, int integer length # function(s) call strcpy( buf, temp) call upper(temp) n = length(temp) if( .not.lib$cvt_htb( %val(n), %ref(temp), %ref(int) ) ) return(ERR) else return(int) end #-t- htoi 327 ascii 15-Jan-84 14:47:09 #-h- initst 1955 ascii 15-Jan-84 14:47:09 ### InitST Initialize runtime system for software tools VOS. subroutine initst character buf(MAXLINE) integer done, i, junk integer getarg, assign, insub, outsub, open, trnlog, equal # function(s) integer outacc, erracc include carg include io include cexith # common block for VMS exit handler external exith string input(FILENAMESIZE) "SYS$INPUT" string output(FILENAMESIZE) "SYS$OUTPUT" string errout(FILENAMESIZE) "SYS$ERROR" string new_ver_log_nam "ST_NEW_VERSIONS" string do_new_versions "YES" data outacc / WRITE / data erracc / WRITE / data done / NO / if( done == YES ) #make sure routine executed only once return done = YES #initialize /carg/ common block nbrarg = 0 # # set up exit handler for all processes which spawn subtasks # desblk(2) = %loc(exith) desblk(3) = 0 desblk(4) = %loc(reason) # the following line was commented out due to FT2 bug!!! # it was not needed anymore, anyways #call sys$dclexh(desblk) # declare VMS exit handler # initialize /io/ common block variables for( i = 1 ; i <= NNFILES ; i = i + 1 ) { lfn(i) = NODEVICE rawchn(i) = NODEVICE # (dpm 8-Jun-81) chstat(i) = OK # (dpm 8-Jun-81) chtimo(i) = MAX_TIMEOUT # (dpm 8-Jun-81) } # determine whether to create new versions junk = trnlog(new_ver_log_nam, tbuf) new_versions = equal(tbuf, do_new_versions) # set up list of command arguments call makarg #pick up file substitutions for standard files for( i = 1 ; i < nbrarg ; ) { j = ptr( i + 1 ) call scopy( arg, j, buf, 1) if( ( insub( buf, input) == YES ) | ( outsub( '>', buf, output, outacc) == YES ) | ( outsub( '?', buf, errout, erracc) == YES ) ) call delarg(i) else i = i + 1 } #open files if( assign( errout, ERROUT, erracc) == ERR ) { % type * , 'Cannot open ERROUT.' call endst(ERR) } if( assign( input, STDIN, READ) == ERR ) call cant(input) if( assign( output, STDOUT, outacc) == ERR ) call cant(output) return end #-t- initst 1955 ascii 15-Jan-84 14:47:09 #-h- inmap 147 ascii 15-Jan-84 14:47:10 ### InMap Map characters from local representation, if required. # This is only a stub. character function inmap(c) character c return(c) end #-t- inmap 147 ascii 15-Jan-84 14:47:10 #-h- insub 235 ascii 15-Jan-84 14:47:10 ### InSub Return whether `arg' is STDIN substitution. integer function insub( arg, file) character arg(ARB), file(ARB) if( arg(1) == '<' & arg(2) != EOS ) { call scopy( arg, 2, file, 1) return(YES) } else return(NO) end #-t- insub 235 ascii 15-Jan-84 14:47:10 #-h- intsrv 378 ascii 15-Jan-84 14:47:11 ### IntSrv ^C AST service routine; gun down all our foreground processes. subroutine intsrv integer i, junk integer kill # function(s) include cproc for( i = 1 ; i <= NFOREGROUND ; i = i + 1 ) if( pid( 1, i) != EOS & pdone(i) == NO ) junk = kill( pid( 1, i) ) call setast(YES) # Indicate that an AST was received. call enbint # Reenable ^C AST. return end #-t- intsrv 378 ascii 15-Jan-84 14:47:11 #-h- isatty 193 ascii 15-Jan-84 14:47:11 ### IsATTY Return whether file behaves like terminal (or printer). integer function isatty(fd) filedes fd include io if( lfn(fd) == TTYDEVICE ) return(YES) else return(NO) end #-t- isatty 193 ascii 15-Jan-84 14:47:11 #-h- itoczf 387 ascii 15-Jan-84 14:47:11 ### IToCZF Convert integer to character string with zero-fill. subroutine itoczf( n, tbuf, width) integer i, m, n, width integer itoc # function(s) character tbuf(ARB), temp(10) m = width - itoc( n, temp, 10) if( m >= 0 ) { for( i = 1 ; i <= m ; i = i + 1 ) tbuf(i) = '0' call scopy( temp, 1, tbuf, i) } else { i = 1 - m call scopy( temp, i, tbuf, 1) } return end #-t- itoczf 387 ascii 15-Jan-84 14:47:11 #-h- kill 326 ascii 15-Jan-84 14:47:12 ### Kill Gun down process `prcid'. integer function kill(prcid) character prcid(PIDSIZE) integer exit_stat, pid, status integer htoi, sys$forcex # function(s) data exit_stat / CHILD_ABORTED / pid = htoi(prcid) status = sys$forcex( pid, , %val(exit_stat) ) if( .not. status ) return(ERR) else return(OK) end #-t- kill 326 ascii 15-Jan-84 14:47:12 #-h- loccom 943 ascii 15-Jan-84 14:47:12 ### LocCom Locate command according to specified search path. integer function loccom( comand, spath, suffix, path) character comand(ARB), spath(ARB), path(ARB), temp(FILENAMESIZE) character suffix(ARB) integer i, j, n, type integer flfind, index, length # function(s) #----- NOTE ----- # Do not write into 'path' until processing is completed, thus allowing loccom # to be called with the same array for 'comand' and 'path' args. #---------------- for( i = 1 ; spath(i) != '@n' ; i = i + length( spath(i) ) + 1 ) { call concat( spath(i), comand, temp) n = length(temp) + 1 if( index( comand, '.') > 0 ) { if( flfind( temp, path, type) != ERR ) return(type) } else { for( j = 1 ; suffix(j) != '@n' ; j = j + length( suffix(j) ) + 1 ) { call scopy( suffix, j, temp, n) if( flfind( temp, path, type) != ERR ) return(type) } } } call strcpy( comand, path) return(ERR) end #-t- loccom 943 ascii 15-Jan-84 14:47:12 #-h- mailid 1315 ascii 15-Jan-84 14:47:12 ### MailId Get our username (used as our mailing address). subroutine mailid(sender) define(USERNAMESIZE,12) character sender(ARB) character buf(MAXLINE), out(FILENAMESIZE) integer rab, n, junk integer openf, gets, getwrd, equal, index, length integer*2 jpibuf(8) integer i, usera equivalence( usera, jpibuf(3) ) string blklp " (" data jpibuf / USERNAMESIZE, JPI_USERNAME, 6*0 / for( i = 1 ; i <= USERNAMESIZE ; i = i + 1 ) sender(i) = ' ' usera = %loc(sender) call sys$getjpi( , , , jpibuf, , , ) for( i = USERNAMESIZE ; i > 0 ; i = i - 1 ) if( sender(i) != ' ' ) break sender( i + 1 ) = EOS call fold(sender) call adrfil(buf) if (openf(buf, 0, 0, READ, -1, rab) != ERR) { repeat { n = gets(rab, buf, MAXCARD) if (n < 0) break buf(n+1) = EOS i = 1 junk = getwrd(buf, i, out) if (equal(out, sender) == YES) # found the record { i = index(buf, '"') # find start of comment string if (i > 0) { n = length(sender) + 1 call stcopy(blklp, 1, sender, n) for (i=i+1; buf(i) != EOS; i=i+1) { if (buf(i) == '"') break call chcopy(buf(i), sender, n) } call chcopy(')', sender, n) } break } } call closef(rab) } return end #-t- mailid 1315 ascii 15-Jan-84 14:47:12 #-h- makarg 581 ascii 15-Jan-84 14:47:13 ### MakArg Get command line and construct array of pointers. subroutine makarg include carg integer iend, j, tog integer getmsg # function(s) iend = getmsg(arg) nbrarg = 0 j = 1 for( i = 1 ; i <= MAXARGS ; i = i + 1 ) { if( j <= iend ) call skipbl( arg, j) if( j > iend ) break ptr(i) = j if( arg(j) == '@'' | arg(j) == '"' ) { tog = arg(j) for( j = j + 1 ; arg(j) != tog & arg(j) != EOS ; j = j + 1 ) ; } else while( arg(j) != ' ' & arg(j) != EOS ) j = j + 1 arg(j) = EOS j = j + 1 } nbrarg = i - 1 return end #-t- makarg 581 ascii 15-Jan-84 14:47:13 #-h- mklocl 571 ascii 15-Jan-84 14:47:13 ### MkLocl Convert from pathname to local (DEC) file spec. subroutine mklocl( in, out) integer depth, i, junk, ptr(10) integer gtftok # function(s) character in(ARB), out(ARB), path(FILENAMESIZE), temp(FILENAMESIZE) character lstchr call mkpath( in, path) # resolve to full path name call exppth( path, depth, ptr, out) if (lstchr(path) != '/') { i = ptr(depth) path(i) = EOS ptr(depth) = ptr(depth) + 1 call gendir( path, out) i = ptr(depth) junk = gtftok( path, i, temp) call concat( out, temp, out) } else call gendir(path, out) return end #-t- mklocl 571 ascii 15-Jan-84 14:47:13 #-h- mkpath 482 ascii 15-Jan-84 14:47:14 ### MkPath Convert "in" string to fully resolved pathname in "path". subroutine mkpath( in, path) character in(ARB), path(ARB), temp(FILENAMESIZE) integer local, i integer index # function(s) string decsep ":[]" local = NO for( i = 1 ; decsep(i) != EOS ; i = i + 1 ) if( index( in, decsep(i)) > 0 ) { local = YES break } if( local == YES ) call cvt_dtop( in, temp) else call strcpy( in, temp) call resdef( temp, path) call str_host( path, temp) return end #-t- mkpath 482 ascii 15-Jan-84 14:47:14 #-h- note 251 ascii 15-Jan-84 14:47:14 ### Note Get file address for next line. integer function note(addr, fd) filedes fd integer addr(2) include io ifdef( VAX_VMS ) call mark( fdb(fd), addr(1), addr(2) ) elsedef call mark( fdb(fd), 0, addr(1), addr(2)) enddef return(OK) end #-t- note 251 ascii 15-Jan-84 14:47:14 #-h- nxtlun 250 ascii 15-Jan-84 14:47:14 ### NxtLUN Find next free logical unit (file descriptor). integer function nxtlun(fd) filedes fd include io for( fd = 1 ; fd <= NNFILES ; fd = fd + 1 ) if( lfn(fd) == NODEVICE ) break if( fd > NNFILES ) fd = ERR return(fd) end #-t- nxtlun 250 ascii 15-Jan-84 14:47:14 #-h- open 305 ascii 15-Jan-84 14:47:15 ### Open Associate file `fil' with descriptor at mode `access'. filedes function open( fil, access) character fil(ARB) filedes fd filedes cre8at, nxtlun # function(s) integer access include io if( nxtlun(fd) == ERR ) return(ERR) else return( cre8at( fil, access, fd, OLDAGE)) end #-t- open 305 ascii 15-Jan-84 14:47:15 #-h- opena 342 ascii 15-Jan-84 14:47:15 ### OpenA Open file `fil' on `fd' with APPEND access. integer function opena( fil, fd, access, age) character fil(ARB) filedes fd filedes openf # function(s) integer access, age include io opena = openf( fil, CHARAC, LISTCC, APPEND, age, fdb(fd) ) if( opena != ERR ) { lastc(fd) = 0 mode(fd) = OUTPUTMODE } return end #-t- opena 342 ascii 15-Jan-84 14:47:15 #-h- opendr 877 ascii 15-Jan-84 14:47:15 ### OpenDr Open directory file for reading with GdrPrm and GdrAux. define( NDIRECTS, 10) # maximum number of open directories integer function opendr( direct, desc) character direct(FILENAMESIZE), temp(FILENAMESIZE) filedes desc integer n integer dopen, length # function(s) external dir_init include cdirec string stars "*.*;*" for( desc = 1 ; desc <= NDIRECTS ; desc = desc + 1 ) if( dfab(desc) == 0 ) break if( desc > NDIRECTS ) desc = ERR else { call mkpath( direct, temp) call gendir( temp, dnam( 1, desc) ) call concat( dnam( 1, desc), stars, temp) call upper(temp) n = length(temp) if( dopen( temp, n, dfab(desc) ) == ERR ) { dfab(desc) = 0 desc = ERR } else lfile( 1, desc) = EOS # initialize last file seen string } return(desc) end block data dir_init include cdirec data dfab / NDIRECTS*0 / end #-t- opendr 877 ascii 15-Jan-84 14:47:15 #-h- openn 323 ascii 15-Jan-84 14:47:16 ### OpenN Open new file `fil' on `fd'. integer function openn( fil, fd, access) character fil(ARB) filedes fd integer access integer openf # function(s) include io openn = openf( fil, CHARAC, LISTCC, READWRITE, NEWAGE, fdb(fd) ) if( openn != ERR ) { lastc(fd) = 0 mode(fd) = OUTPUTMODE } return end #-t- openn 323 ascii 15-Jan-84 14:47:16 #-h- openp 364 ascii 15-Jan-84 14:47:16 ### OpenP Open file `fil' on `fd' for printing (Fortran carriage control). integer function openp( fil, fd, access) character fil(FILENAMESIZE) filedes fd integer access integer openf # function(s) include io openp = openf( fil, CHARAC, FORTCC, WRITE, NEWAGE, fdb(fd) ) if( openp != ERR ) { lastc(fd) = 0 mode(fd) = OUTPUTMODE } return end #-t- openp 364 ascii 15-Jan-84 14:47:16 #-h- openr 348 ascii 15-Jan-84 14:47:16 ### OpenR Open file `fil' on `fd' with READ access. integer function openr( fil, fd, access) character fil(ARB) filedes fd integer access integer openf # function(s) include io openr = openf( fil, CHARAC, LISTCC, READ, OLDAGE, fdb(fd) ) if( openr != ERR ) { lastc(fd) = 0 bcount(fd) = 0 mode(fd) = INPUTMODE } return end #-t- openr 348 ascii 15-Jan-84 14:47:16 #-h- opens 340 ascii 15-Jan-84 14:47:17 ### OpenS Open file `fil' on `fd' with READWRITE access. integer function opens(fil, fd, access) character fil(ARB) filedes fd integer access integer openf # function(s) include io opens = openf( fil, CHARAC, LISTCC, READWRITE, UNKAGE, fdb(fd) ) if( opens != ERR ) { lastc(fd) = 0 mode(fd) = OUTPUTMODE } return end #-t- opens 340 ascii 15-Jan-84 14:47:17 #-h- openw 653 ascii 15-Jan-84 14:47:17 ### OpenW Open file `fil' on `fd' with WRITE/READWRITE access. integer function openw( fil, fd, access, age) character fil(ARB) filedes fd integer acc, access, filtyp, age, local_age integer openf # function(s) include io if( access == BINARY_WRITE ) # (dpm 7-Sep-81) { acc = WRITE filtyp = BINAR } else { acc = access filtyp = CHARAC } if (age == UNKAGE & new_versions == YES & access != READWRITE) local_age = NEWAGE else local_age = age openw = openf( fil, filtyp, LISTCC, acc, local_age, fdb(fd) ) if( openw != ERR ) { lastc(fd) = 0 mode(fd) = OUTPUTMODE if( acc == READWRITE ) bcount(fd) = 0 } return end #-t- openw 653 ascii 15-Jan-84 14:47:17 #-h- outmap 154 ascii 15-Jan-84 14:47:17 ### OutMap Map ASCII characters into local character set, if required. # This is only a stub. character function outmap(c) character c return(c) end #-t- outmap 154 ascii 15-Jan-84 14:47:17 #-h- outsub 432 ascii 15-Jan-84 14:47:18 ### OutSub Determine if argument is output file substitution. integer function outsub(c, arg, file, access) character arg(ARB), c, file(ARB) integer access, i if( arg(1) == c ) if( arg(2) == c ) { if( arg(3) != EOS ) { access = APPEND call scopy( arg, 3, file, 1) return(YES) } } else if( arg(2) != EOS ) { access = WRITE call scopy( arg, 2, file, 1) return(YES) } return(NO) end #-t- outsub 432 ascii 15-Jan-84 14:47:18 #-h- parsef 818 ascii 15-Jan-84 14:47:18 ### ParseF Parse DEC filespec into node, device, dir, and file strings. subroutine parsef( in, node, device, direct, file) character in(ARB), node(ARB), device(ARB), direct(ARB), file(ARB) integer start, stop integer index # function(s) start = 1 stop = start + index( in(start), ':') - 1 if( stop >= start & in( stop + 1 ) == ':' ) { call copyit( in, start, stop - 1, node) start = stop + 2 stop = start + index( in(start), ':') - 1 } else node(1) = EOS if( stop >= start ) { call copyit( in, start, stop - 1, device) start = stop + 1 } else device(1) = EOS if( in(start) == '[' ) { stop = start + index( in(start), ']') - 1 if( stop < start ) stop = start call copyit( in, start, stop, direct) start = stop + 1 } else direct(1) = EOS call scopy( in, start, file, 1) return end #-t- parsef 818 ascii 15-Jan-84 14:47:18 #-h- pgflts 308 ascii 15-Jan-84 14:47:18 ### PgFlts Get the number of page faults incurred less `start'. integer function pgflts(start) integer pgf, pgfbuf, start integer*2 jpibuf(8) equivalence( pgfbuf, jpibuf(3) ) data jpibuf / 4, JPI_PAGEFLTS, 6*0 / pgfbuf = %loc(pgf) call sys$getjpi( , , , jpibuf, , , ) return( pgf - start ) end #-t- pgflts 308 ascii 15-Jan-84 14:47:18 #-h- prcdon 1175 ascii 15-Jan-84 14:47:19 ### PrcDon Display process termination status message. subroutine prcdon integer j, ptr integer equal # function(s) character buf(PIDSIZE) include cproc include ctrmbx ptr = 0 call puthex( iosb(2), buf) for( j = 1 ; j <= NPROCESSES & ptr == 0 ; j = j + 1 ) if( equal( pid( 1, j), buf) == YES ) ptr = j if( ptr != 0 ) { pdone(ptr) = YES for( j = 1 ; j <= TERMSGSIZE ; j = j + 1 ) pmsg( j, ptr) = termsg(j) if( ptr <= NFOREGROUND & n4grnd > 0 ) n4grnd = n4grnd - 1 } if( n4grnd <= 0 ) for( j = NFOREGROUND + 1 ; j <= NPROCESSES ; j = j + 1 ) if( pdone(j) == YES & pid( 1, j) != EOS ) { if (spunit != ERR) { call putlin( "background process ", spunit) call putlin( pid( 1, j), spunit) call putlin( " terminated", spunit) if( .not. pmsg( 2, j) & pmsg( 2, j) != 0 ) { call putlin( " abnormally. Return status = ", spunit) call puthex( pmsg( 2, j), buf) call putlin( buf, spunit) } else call putlin( " successfully", spunit) call putch( '@n', spunit) } call putpdb(j) } call rdtmbx return end #-t- prcdon 1175 ascii 15-Jan-84 14:47:19 #-h- prompt 1180 ascii 15-Jan-84 14:47:19 ### Prompt Read line from `in', prompting if a terminal. integer function prompt( pbuf, line, in) character buf(MAXLINE), line(ARB), pbuf(ARB) filedes in, out integer i, n integer create, getlin, length, rdpmpt # function(s) include io string term TTY_NAME string crlf "@r@l" string under "_" if( lfn(in) == TTYDEVICE & pbuf(1) != EOS ) { for( n = length(pbuf) ; n > 0 ; n = n - 1 ) if( pbuf(n) == '@n' ) break if( n > 0 ) # have a multi-line prompt { for( i = 1 ; i <= n ; i = i + 1 ) buf(i) = pbuf(i) buf(i) = EOS out = create( term, WRITE) if( out != ERR ) { call putlin( buf, out) call close(out) } } n = n + 1 i = 1 call stcopy( crlf, 1, buf, i) call strcpy( pbuf(n), buf(i) ) } else buf(1) = EOS n = 1 repeat { if( buf(1) == EOS ) i = getlin( line(n), in) else { i = rdpmpt( fdb(in), buf, length(buf), line(n), MAXCARD - n ) buf(3) = pbuf(1) call strcpy( under, buf(4) ) } if( i < 0 ) return(EOF) n = n + i if( n <= 2 ) break if( line( n - 2 ) != '@@' ) # not an escaped '@n' break n = n - 1 line( n - 1 ) = ' ' } return( n - 1 ) end #-t- prompt 1180 ascii 15-Jan-84 14:47:19 #-h- pstat 409 ascii 15-Jan-84 14:47:20 ### Pstat Get status of specified process. integer function pstat(buf) character buf(PIDSIZE) integer astate, pid, state, status integer htoi, sys$getjpi # function(s) integer*2 jpibuf(8) equivalence( astate, jpibuf(3) ) data jpibuf / 4, JPI_STATE, 6*0 / astate = %loc(state) pid = htoi(buf) status = sys$getjpi( , pid, , jpibuf, , , ) if( .not. status ) return(ERR) else return(OK) end #-t- pstat 409 ascii 15-Jan-84 14:47:20 #-h- ptrcpy 171 ascii 15-Jan-84 14:47:20 ### PtrCpy Copy pointer from `in' to `out'. subroutine ptrcpy( in, out) integer in(2), out(2) out(1) = in(1) if( in(1) != NULLPOINTER ) out(2) = in(2) return end #-t- ptrcpy 171 ascii 15-Jan-84 14:47:20 #-h- ptreq 264 ascii 15-Jan-84 14:47:20 ### PtrEq Test `ptr1' and `ptr2' for equality. integer function ptreq( ptr1, ptr2) integer ptr1(2), ptr2(2) if( ptr1(1) == ptr2(1) ) { if( ptr1(1) == NULLPOINTER ) return(YES) else if( ptr1(2) == ptr2(2) ) return(YES) } else return(NO) end #-t- ptreq 264 ascii 15-Jan-84 14:47:20 #-h- ptrtoc 556 ascii 15-Jan-84 14:47:21 ### PtrToC Convert pointer to character string. integer function ptrtoc( ptr, buf, size) integer i, j, junk, ptr(2), size integer addset, itoc, length # function(s) character buf(size), temp(7) junk = itoc( ptr(1), temp, 7) j = 1 for( i = 1 ; temp(i) != EOS ; i = i + 1 ) junk = addset( temp(i), buf, j, size) junk = addset( ' ', buf, j, size) junk = itoc( ptr(2), temp, 7) for( i = 1 ; temp(i) != EOS ; i = i + 1 ) junk = addset( temp(i), buf, j, size) if( addset( EOS, buf, j, size) == ERR ) buf(size) = EOS return( length(buf) ) end #-t- ptrtoc 556 ascii 15-Jan-84 14:47:21 #-h- putch 714 ascii 15-Jan-84 14:47:21 ### PutCh Put character on file `fd'. subroutine putch( c, fd) character c character outmap # function(s) filedes fd integer i, n integer puts # function(s) include io chstat(fd) = OK if( chtype(fd) != COOKED ) { call rputch( c, 1, fd) # (dpm 8-Jun-81) return } if( mode(fd) != OUTPUTMODE ) { mode(fd) = OUTPUTMODE lastc(fd) = 0 } n = lastc(fd) if( n >= MAXLINE | c == '@n' ) { chstat(fd) = puts( fdb(fd), buffer( 1, fd), n) lastc(fd) = 0 } if( c != '@n' ) { lastc(fd) = lastc(fd) + 1 n = lastc(fd) # use the following line if the characters have to be mapped # buffer(n, fd) = outmap(c) # use the following line if no mapping required buffer( n, fd) = c } return end #-t- putch 714 ascii 15-Jan-84 14:47:21 #-h- puthex 300 ascii 15-Jan-84 14:47:21 ### PutHex Format `n' into `buf' as a hexadecimal character string. subroutine puthex( n, buf) integer n, fmt(2), out(2) character buf(ARB) string fmtbuf "!XL" call dscbld( fmt, fmtbuf) out(1) = 9 out(2) = %loc(buf) call sys$fao( fmt, , out, %val(n) ) buf(9) = EOS call fold(buf) return end #-t- puthex 300 ascii 15-Jan-84 14:47:21 #-h- putlin 363 ascii 15-Jan-84 14:47:22 ### PutLin Output a line of text to `fd' by repeated calls to PutCh. subroutine putlin( b, fd) character b(ARB) filedes fd integer i integer length # function(s) include io if( chtype(fd) != COOKED ) { i = length(b) call rputch( b, i, fd) # (dpm 8-Jun-81) } else for( i = 1 ; b(i) != EOS ; i = i + 1 ) call putch( b(i), fd) return end #-t- putlin 363 ascii 15-Jan-84 14:47:22 #-h- putpdb 320 ascii 15-Jan-84 14:47:22 ### PutPDB Mark process as nonexistant and deassign mailbox. subroutine putpdb(offset) integer offset include cproc call sys$setast( %val(0) ) # disable AST delivery pid( 1, offset) = EOS pdone(offset) = NO call sys$dassgn( %val( mbxchn(offset) ) ) call sys$setast( %val(1) ) # enable AST delivery return end #-t- putpdb 320 ascii 15-Jan-84 14:47:22 #-h- pwait 767 ascii 15-Jan-84 14:47:22 ### PWait Wait for completion of foreground process(es). integer function pwait( nprocs, pids, pinfo, lstpid, flag) character lstpid(PIDSIZE), pids( PIDSIZE, ARB) integer flag, i, j, k, nprocs, pinfo(TERMSGSIZE, ARB) integer equal # function(s) include cproc for( i = 1 ; i <= nprocs ; i = i + 1 ) { for( j = 1 ; j <= NFOREGROUND & equal( pid( 1, j), pids( 1, i)) == NO ; j = j + 1 ) if( j > NFOREGROUND ) next while( pdone(j) != YES ) call wtmsec(100) # wait 100 msec for( k = 1 ; k <= TERMSGSIZE ; k = k + 1 ) pinfo( k, i) = pmsg( k, j) call strcpy( pids( 1, i), lstpid) call putpdb(j) } if( pinfo( 2, 1) == CHILD_ABORTED ) # return status of first process return( CHILD_ABORTED ) else return(OK) end #-t- pwait 767 ascii 15-Jan-84 14:47:22 #-h- quotas 701 ascii 15-Jan-84 14:47:23 ### Quotas Set up VMS quotas for spawning subprocesses. subroutine quotas(wait) integer fillm, fillma, mul integer*2 qlist(8) character wait equivalence( fillma, qlist(3) ) include cquota data qlist / 4, JPI_FILLM, 4*0, 2*0 / b1 = pqlastlm l1 = ASTLM b2 = pqlbiolm l2 = BIOLM b3 = pqlbytlm b4 = pqlcpulm l4 = CPULM b5 = pqldiolm l5 = DIOLM b6 = pqlfillm b7 = pqlpgflquota b8 = pqlprclm b9 = pqltqelm ba = pqlwsquota la = WSQUOTA bb = pqlwsdefault lb = WSDEFAULT b0 = pqllistend fillma = %loc(fillm) call sys$getjpi( , , , qlist, , , ) mul = fillm / FILLM if( mul > 1 ) mul = mul - 1 l3 = mul * BYTLM l6 = mul * FILLM l7 = mul * PGFLQUOTA l8 = mul * PRCLM l9 = mul * TQELM return end #-t- quotas 701 ascii 15-Jan-84 14:47:23 #-h- rdtmbx 253 ascii 15-Jan-84 14:47:23 ### RdTMbx Post a read request from the termination mailbox. subroutine rdtmbx include ctrmbx external prcdon call sys$qio( , %val(termbx), %val(IO_READVBLK), iosb, prcdon, , termsg, %val(TERMSGSIZEBYTE), , , ,) return end #-t- rdtmbx 253 ascii 15-Jan-84 14:47:23 #-h- readf 349 ascii 15-Jan-84 14:47:23 ### ReadF Read "n" bytes from "fd" into "buf". integer function readf( buf, n, fd) character buf(ARB) filedes fd integer count, n integer gets # function(s) include io if( 1 <= fd & fd <= NNFILES ) andif( lfn(fd) != NODEVICE ) { count = gets( fdb(fd), buf, n) if( count >= 0 ) return(count) } return(EOF) end #-t- readf 349 ascii 15-Jan-84 14:47:23 #-h- realdev 569 ascii 15-Jan-84 14:47:24 ### Real_device Return whether 1st token of `path' is a device name. integer function real_device(path) character path(ARB), temp(FILENAMESIZE), temp1(FILENAMESIZE) integer dsc(2), i, junk, pbd(2), pbuf integer gtftok, sys$getdev, index, trnlog # function(s) string colon ":" i = 2 junk = gtftok( path, i, temp) call upper(temp) junk = trnlog( temp, temp1) if( index( temp1, ':') == 0 ) call concat( temp1, colon, temp1) call dscbld( dsc, temp1) pbd(1) = 4 pbd(2) = %loc(pbuf) if( .not.sys$getdev( dsc, , pbd, , ) ) return(NO) else return(YES) end #-t- realdev 569 ascii 15-Jan-84 14:47:24 #-h- remark 283 ascii 15-Jan-84 14:47:24 ### Remark Output message on ERROUT; assure '@n'. subroutine remark(line) character line(ARB) for( i = 1 ; line(i) != EOS ; i = i + 1 ) call putch( line(i), ERROUT) if (i == 1) call putch('@n', ERROUT) else if( line( i - 1 ) != '@n' ) call putch( '@n', ERROUT) return end #-t- remark 283 ascii 15-Jan-84 14:47:24 #-h- remove 310 ascii 15-Jan-84 14:47:24 ### Remove Remove file `fil'. integer function remove(fil) character fil(FILENAMESIZE) filedes fd integer fdel, open # function(s) integer status include io status = OK fd = open( fil, READ) if( fd != ERR ) { if( fdel( fdb(fd) ) < 0 ) status = ERR call close(fd) } return(status) end #-t- remove 310 ascii 15-Jan-84 14:47:24 #-h- resdef 1077 ascii 15-Jan-84 14:47:25 ### ResDef Resolve defaults, generating full from partial pathname. subroutine resdef( cpath, dpath) character tpath(FILENAMESIZE), c character cpath(ARB), dpath(ARB), temp(FILENAMESIZE) character lstchr integer depth, i, j, level, ptr(MAXDIRECTS) integer equal, gtftok, real_device # function(s) string backsl "\" string dotdot ".." call gtdpth(dpath) call exppth( dpath, depth, ptr, temp) c = lstchr(cpath) call res_tilde( cpath, tpath) if( tpath(1) == EOS ) # No such place (dpm 11-Jul-81) { dpath(1) = EOS return } else if( tpath(1) == '/' ) { if( tpath(2) == '@@' ) level = 1 else if( real_device(tpath) == YES ) level = 2 else level = 3 } else level = depth + 1 j = ptr(level) i = 1 while( gtftok( tpath, i, temp) > 0 ) { if( equal( temp, dotdot) == YES | equal( temp, backsl) == YES ) { level = level - 1 j = ptr(level) } else { ptr(level) = j level = level + 1 dpath(j) = '/' j = j + 1 call stcopy( temp, 1, dpath, j) } } if (c == '/') call chcopy('/', dpath, j) dpath(j) = EOS return end #-t- resdef 1077 ascii 15-Jan-84 14:47:25 #-h- restilde 2499 ascii 15-Jan-84 14:47:25 ### ResTilde Resolve `~' prefixed pathnames. subroutine res_tilde( path, out) character buf(MAXLINE), out(ARB), path(ARB), token(FILENAMESIZE) integer found, i, j, junk, key, n, rab integer equal, gets, getwrd, gtftok, length, openf # function(s) string bin "bin" string usr "usr" string tmp "tmp" string lpr "lpr" string msg "msg" string mail "mail" # WARNING!!! Goes away on 1-Jan-83 (dpm 15-Dec-81) string man "man" string src "src" string inc "inc" string lib "lib" string start "/st_" string slashs "/" if( path(1) != '~' ) { call strcpy( path, out) if (out(1) == '/' & out(2) == '\') out(2) = '@@' else if (out(1) == '.' & out(2) == '/') call scopy(out, 3, out, 1) } else { found = YES i = 2 key = ERR if( path(i) == '/' | path(i) == EOS ) { call homdir(token, LOCAL) # bare '~' => home directory (dpm 16-Jun-81). key = OK } else { junk = gtftok( path, i, token) call fold(token) if( equal( token, bin) == YES ) key = BINDIRECTORY else if( equal( token, usr) == YES ) key = USRDIRECTORY else if( equal( token, tmp) == YES ) key = TMPDIRECTORY else if( equal( token, lpr) == YES ) key = LPRDIRECTORY else if( equal( token, msg) == YES ) key = MSGDIRECTORY else if( equal( token, mail) == YES ) # WARNING!!! Goes away on key = MSGDIRECTORY # 1-Jan-83 (dpm 15-Dec-81) else if( equal( token, man) == YES ) key = MANDIRECTORY else if( equal( token, src) == YES ) # (dpm 8-Jun-81) key = SRCDIRECTORY else if( equal( token, inc) == YES ) # (dpm 24-Sep-81) key = INCDIRECTORY else if( equal( token, lib) == YES ) # (dpm 24-Sep-81) key = LIBDIRECTORY if( key != ERR ) call getdir( key, LOCAL, token) } if( key == ERR ) { call adrfil(buf) call upper(buf) found = NO if( openf( buf, 0, 0, READ, -1, rab) != ERR ) { repeat { n = gets( rab, buf, MAXCARD) if( n < 0 ) break buf( n + 1 ) = EOS j = 1 junk = getwrd( buf, j, out) if( equal( out, token) == YES ) { junk = getwrd( buf, j, token) found = YES break } } call closef(rab) } } if( found == YES ) call cvt_dtop( token, out) else { call concat(start, token, out) call concat(out, slashs, out) } j = length(out) + 1 if (path(i) == '/') i = i + 1 call scopy( path, i, out, j) } return end #-t- restilde 2499 ascii 15-Jan-84 14:47:25 #-h- resuic 910 ascii 15-Jan-84 14:47:26 ### ResUIC Resolve UIC into username. define( MAX_PTR, 2500) # maximum number of login names define( MAX_TBL,arith(MAX_PTR,*,25)) # total storage needed subroutine resuic( uic, value) character buf(MAXLINE), name(FILENAMESIZE), uic(ARB), value(ARB) character defn(FILENAMESIZE) filedes fd integer i, init, junk integer getlin, getwrd, length, open, lookup # function(s) include clook data init / YES / if( init == YES ) { lastp = 0 lastt = 0 call adrfil(name) fd = open( name, READ) # open address file if( fd == ERR ) call remark( "? Can't open user's file" ) else { while( getlin( buf, fd) != EOF ) { i = 1 junk = getwrd( buf, i, defn) junk = getwrd( buf, i, name) junk = getwrd( buf, i, name) call instal( name, defn) } call close(fd) } init = NO } if( lookup( uic, value) == NO ) call strcpy( uic, value) return end #-t- resuic 910 ascii 15-Jan-84 14:47:26 #-h- resume 261 ascii 15-Jan-84 14:47:26 ### Resume Resume suspended process. integer function resume(buf) character buf(PIDSIZE) integer pid, status integer htoi, sys$resume # function(s) pid = htoi(buf) status = sys$resume( pid, ) if( .not. status ) return(ERR) else return(OK) end #-t- resume 261 ascii 15-Jan-84 14:47:26 #-h- rgetch 1137 ascii 15-Jan-84 14:47:27 ### RGetCh Get a (RAW or RARE) character `c' from channel `chan'. (VMS) character function rgetch(c, chan) include io character c integer chan, func, iostat, rawfn, rarefn integer*2 iosb(4) integer*4 sys$qiow define(READ_MODIFIERS,arith(IO_M_NOECHO,+,IO_M_TIMED)) data rawfn / arith(IO_TTYREADALL,+,READ_MODIFIERS) / data rarefn / arith(arith(IO_READLBLK,+,IO_M_NOFILTER),+,READ_MODIFIERS) / iostat = SS_NORMAL if( chtype(chan) == RAW ) func = rawfn else if( chtype(chan) == RARE ) func = rarefn else iostat = (.not. SS_NORMAL) if( iostat == SS_NORMAL ) iostat = sys$qiow( , # event flag number %val(rawchn(chan)), # channel number %val(func), # function code iosb, # io status block , # AST address , # AST parameter %ref(c), # input buffer address %val(1), # input buffer size %val(chtimo(chan)), # timeout count , # terminator block address , # prompt buffer address ,) # prompt buffer size if( iostat != SS_NORMAL | iosb(1) != SS_NORMAL ) { if( iosb(1) == SS_TIMEOUT ) c = TMO else c = ERR chstat(chan) = c } else chstat(chan) = OK return(c) end #-t- rgetch 1137 ascii 15-Jan-84 14:47:27 #-h- rputch 754 ascii 15-Jan-84 14:47:27 ### RPutCh Output `n' characters on `chan'. subroutine rputch(str, n, chan) include io character str(ARB) integer chan, func, iostat, n integer*4 sys$qiow integer*2 iosb(4) data func / arith(IO_WRITEVBLK,+,IO_M_NOFORMAT) / iostat = sys$qiow( , # event flag number %val(rawchn(chan)), # channel number %val(func), # function code iosb, # io status block , # AST address , # AST parameter %ref(str), # output buffer address %val(n), # output buffer size , # p3 (ignored) , # carriage control , # p5 (ignored) ,) # p6 (ignored) if( iostat != SS_NORMAL ) { chstat(chan) = ERR return } if( iosb(1) == SS_NORMAL | iosb(1) == SS_CONTROLO ) chstat(chan) = OK else chstat(chan) = ERR return end #-t- rputch 754 ascii 15-Jan-84 14:47:27 #-h- rtopen 336 ascii 15-Jan-84 14:47:27 ### RTOpen Open an unCOOKED terminal channel integer function rtopen( term, chan) character term(ARB) character buf(FILENAMESIZE) integer chan, dsc(2), junk integer sys$assign, trnlog # function(s) junk = trnlog( term, buf) call dscbld( dsc, buf) if( .not. sys$assign( dsc, chan, , ) ) return(ERR) else return(OK) end #-t- rtopen 336 ascii 15-Jan-84 14:47:27 #-h- scratf 601 ascii 15-Jan-84 14:47:28 ### Scratf Generate scratch file name in `target', using `start' as seed. subroutine scratf( start, target) character direc(FILENAMESIZE), start(ARB), target(ARB) integer i, init, j, n integer length # function(s) data init / YES / if( init == YES ) { call getdir( TMPDIRECTORY, LOCAL, direc) i = length(direc) + 1 call chcopy( 't', direc, i) call unique( direc(i) ) init = NO } i = 1 call stcopy( direc, 1, target, i) target(i) = '.' i = i + 1 n = length(start) n = min( n, 3) for( j = 1 ; j <= n ; j = j + 1 ) { target(i) = start(j) i = i + 1 } target(i) = EOS return end #-t- scratf 601 ascii 15-Jan-84 14:47:28 #-h- seek 609 ascii 15-Jan-84 14:47:28 ### Seek Position file open on `fd' at record `offset'. subroutine seek( offset, fd) character c character getch # function(s) filedes fd integer offset(2), tmpoff(2) include io if( offset(1) == BEGINNING_OF_FILE ) # (dpm 2-Nov-81) { tmpoff(1) = 0 tmpoff(2) = 0 call point( fdb(fd), tmpoff(1), tmpoff(2)) } else if( offset(1) == END_OF_FILE ) # (dpm 2-Nov-81) { tmpoff(1) = 0 tmpoff(2) = 0 call point( fdb(fd), tmpoff(1), tmpoff(2)) while( getch( c, fd) != EOF ) ; } else call point( fdb(fd), offset(1), offset(2)) #IAS call point( fdb(fd), 0, offset(1), offset(2)) return end #-t- seek 609 ascii 15-Jan-84 14:47:28 #-h- setast 171 ascii 15-Jan-84 14:47:28 ### SetAST Change the value of the AST-received flag. subroutine setast(state) integer state include cast if( state == YES | state == NO ) gotast = state return end #-t- setast 171 ascii 15-Jan-84 14:47:28 #-h- sleep 1223 ascii 15-Jan-84 14:47:29 ### Sleep Hibernate for a specified number of seconds. subroutine sleep(secnds) define( MAXSECONDS, 864000) # max is 10 days integer days, hours, i, junk, mins, secnds, secs, systim(2), tdesc(2) integer timer_efn integer lib$get_ef, sys$bintim # function(s) character tbuf(5), time(20) data timer_efn / 0 / if( timer_efn == 0 ) junk = lib$get_ef( timer_efn ) if( secnds <= 0 ) return days = 0 hours = 0 mins = 0 if( secnds > MAXSECONDS ) secs = MAXSECONDS else secs = secnds if( secs >= 60 ) { mins = secs / 60 secs = secs - 60 * mins } if( mins >= 60 ) { hours = mins / 60 mins = mins - 60 * hours } if( hours >= 24 ) { days = hours / 24 hours = hours - 24 * days } i = 1 call itoczf( days, tbuf, 4) call stcopy( tbuf, 1, time, i) call chcopy( ' ', time, i) call itoczf( hours, tbuf, 2) call stcopy( tbuf, 1, time, i) call chcopy( ':', time, i) call itoczf( mins, tbuf, 2) call stcopy( tbuf, 1, time, i) call chcopy( ':', time, i) call itoczf( secs, tbuf, 2) call stcopy( tbuf, 1, time, i) call scopy( ".00", 1, time, i) call dscbld( tdesc, time) if( sys$bintim( tdesc, systim) ) { call sys$setimr( %val( timer_efn ), systim, , ) call sys$waitfr( %val( timer_efn ) ) } return end #-t- sleep 1223 ascii 15-Jan-84 14:47:29 #-h- spawn 6030 ascii 15-Jan-84 14:47:29 ### Spawn Spawn process with arguments. integer function spawn( proces, args, desc, inwait) character proces(FILENAMESIZE), args(ARGBUFSIZE), desc(PIDSIZE) character inwait, wait, msg(ARGBUFSIZE), prname(20), bxname(20) character termnl(FILENAMESIZE), tty(FILENAMESIZE) character image(FILENAMESIZE), temp(FILENAMESIZE) character clower character outfil(FILENAMESIZE), errfil(FILENAMESIZE), c integer init, junk, i, terunt, n, boxunt, status, uic, prior, baspri integer stsflg, dcl, start, stop, j, inpdsc(2), outdsc(2), errdsc(2) integer imgdsc(2), prcdsc(2), prvadr(2), unit, lpid, offset, sys$creprc integer trm_info(TERMSGSIZE,1) # only 1 process at a time for now. integer opnout, opnerr, outmod, ind integer filnfo, gtmode, indexs, stmode integer trnlog, crembx, open, getpdb, equal, pwait, dclout include cproc include ctrmbx include cquota string blkgtr " >" string blkqmk " ?" string trmbox(20) "TRMBX" string nuldev "NLA0:" string login "sys$system:loginout.exe" string dodcl "$@@st_bin:dodcl/output=" string nover "$set noverify@n" string ass1 "$assign/user " string ass2 " TT@n" string ass3 "$assign " string ass4 " SYS$COMMAND@n" data init / YES / if( init == YES ) { init = NO junk = trnlog( "TT", tty) # translate to TTXn: for( i = 1 ; i <= NPROCESSES ; i = i + 1 ) call putpdb(i) # initialize PDB array n4grnd = 0 # no foreground processes if( crembx( trmbox, YES, termbx, terunt) == ERR ) call error( "Cannot create termination mailbox" ) spunit = open( tty, WRITE) # establish unit for AST writes if( spunit == ERR ) call remark( "Cannot open tty unit for spawn AST writes" ) call rdtmbx # start asynch read loop of mbox } if( args(1) == EOS ) return(ERR) # must be some args wait = clower(inwait) # case makes no difference if( getpdb( offset, wait) == ERR ) return(ERR) # no available PDB's opnout = ERR opnerr = ERR outmod = ERR call strcpy( proces, pname( 1, offset) ) # copy name into block call strcpy( args, msg) # copy arguments call genpnm( prname, wait, offset - NFOREGROUND ) # generate p name call arggen( prname, bxname) # generate mailbox name call getprv(prvadr) # get privileges authorized to pass call getbpr(baspri) # Get our base priority. (dpm 9-Jun-81) stsflg = 0 status = crembx( bxname, NO, mbxchn(offset), boxunt) if( status != ERR ) { unit = open( bxname, READWRITE) if( unit == ERR ) status = ERR } if( status != ERR ) { if( wait == BACKGR ) { call getuic(uic) prior = baspri / 2 call strcpy( nuldev, termnl) } else { uic = 0 prior = baspri # Use our base priority (dpm 9-Jun-81) call strcpy( tty, termnl) } call strcpy( proces, image) call fold(image) dcl = NO if( equal( image, "local" ) == YES ) { dcl = YES if (wait == BACKGR) stsflg = 64 call strcpy( login, image) i = 1 call stcopy( dodcl, 1, msg, i) call strcpy( termnl, temp) status = dclout( args, start, stop, temp) call stcopy( temp, 1, msg, i) call chcopy( ' ', msg, i) if( status == YES ) { for( j = 1 ; j <= start ; j = j + 1 ) call chcopy( args(j), msg, i) j = stop } else j = 1 call scopy( args, j, msg, i) call dscbld( inpdsc, bxname) call dscbld( outdsc, nuldev) } else { call dscbld( inpdsc, termnl) call dscbld( outdsc, termnl) if( wait == WAIT ) { if( indexs( msg, blkgtr) == 0 ) { if( filnfo( STDOUT, outfil, junk) == OK ) { opnout = STDOUT outmod = gtmode(STDOUT) call appred( STDOUT, '>', outfil, msg) } } ind = indexs( msg, blkqmk) if( ind != 0 ) { c = msg( ind + 2 ) if( c == ' ' | c == '@t' | c == EOS ) ind = 0 } if( ind == 0 ) { if( filnfo( ERROUT, errfil, junk) == OK ) { opnerr = ERROUT call appred( ERROUT, '?', errfil, msg) } } } } call dscbld( errdsc, termnl) call dscbld( imgdsc, image) call dscbld( prcdsc, prname) call upper(image) call quotas (wait) # call dspprv(JPI_CURPRIV) # call dspprv(JPI_PROCPRIV) call sys$setast( %val(0) ) # disable AST delivery status = sys$creprc( lpid, # created proc ID imgdsc, # image name inpdsc, # sys$input outdsc, # sys$output errdsc, # sys$error prvadr, # privilege vector b1, # quota list prcdsc, # process name %val(prior), # base priority %val(uic), # UIC %val(terunt), # termination mbox %val(stsflg) ) # status flag if( status != SS_NORMAL ) { status = ERR call sys$setast( %val(1) ) # enable AST delivery } else { n = length(msg) if( dcl == YES ) { call putlin( nover, unit) call putlin( ass1, unit) call putlin( tty, unit) call putlin( ass2, unit) call putlin( ass3, unit) call putlin( tty, unit) call putlin( ass4, unit) call putlin( msg, unit) call putch( '@n', unit) } else { i = IO_WRITEVBLK + IO_M_NOW call sys$qiow( %val(1), # event flag number %val( mbxchn(offset) ), # channel number %val(i), # function code , # io status block , # AST address , # AST parameter msg, # output buffer addr %val(n), # output buffer size , # p3 (ignored) , # carriage control , # p5 (ignored) ,) # p6 (ignored) } call close(unit) call puthex( lpid, desc) call strcpy( desc, pid( 1, offset) ) if( wait != BACKGR ) n4grnd = n4grnd + 1 call sys$setast( %val(1) ) # enable AST delivery status = OK if( wait == WAIT ) andif( pwait( 1, desc, trm_info(1,1), desc, ORWAIT) == CHILD_ABORTED ) status = CHILD_ABORTED } } call sreset( opnout, outfil) if( outmod != ERR ) junk = stmode( STDOUT, outmod) call sreset( opnerr, errfil) if( status == ERR | status == CHILD_ABORTED ) call putpdb(offset) return(status) end #-t- spawn 6030 ascii 15-Jan-84 14:47:29 #-h- sreset 222 ascii 15-Jan-84 14:47:30 ### SReset Reset channel assignment. subroutine sreset( unit, file) integer unit, junk integer assign # function(s) character file(FILENAMESIZE) if( unit != ERR ) junk = assign( file, unit, APPEND) return end #-t- sreset 222 ascii 15-Jan-84 14:47:30 #-h- srttim 455 ascii 15-Jan-84 14:47:30 ### SrtTim ??? subroutine srttim( date, out) character out(ARB), temp(10) integer date(2), i, idate(2), j, k, n, x integer itoc # function(s) integer*2 jdate(4), y equivalence( idate(1), jdate(1) ), ( x, y) idate(1) = date(1) idate(2) = date(2) x = 0 k = 1 for( i = 4 ; i > 0 ; i = i - 1 ) { y = jdate(i) n = itoc( x, temp, 10) for( j = 6 ; j > n ; j = j - 1 ) call chcopy( ' ', out, k) call stcopy( temp, 1, out, k) } return end #-t- srttim 455 ascii 15-Jan-84 14:47:30 #-h- stdflt 1189 ascii 15-Jan-84 14:47:31 ### StDflt Reset current working directory. subroutine stdflt( host, device, direct) character host(ARB), device(ARB), direct(ARB), lhost(FILENAMESIZE) character tstr(FILENAMESIZE) integer eql(2), i, init, log(2), status integer crelogsup, equal, sys$crelog, sys$setddir # function(s) data init / YES / if( init == YES ) { call hostnm(lhost) init = NO } call fold(host) i = 1 if( equal( host, lhost) != YES & host(1) != EOS ) { call stcopy( host, 1, tstr, i) call stcopy( "::", 1, tstr, i) } call stcopy( device, 1, tstr, i) call scopy( ":", 1, tstr, i) call upper(tstr) # call remark(tstr) call dscbld( log, "SYS$DISK" ) call dscbld( eql, tstr) status = crelogsup( log, eql) # Try supervisor mode (dpm 9-Nov-81) if( .not. status ) { status = sys$crelog( %val(2), log, eql, ) if( .not. status ) { call puthex( status, tstr) call putlin( "Error in assigning sys$disk: ", ERROUT) call remark(tstr) } } call upper(direct) # call remark(direct) call dscbld( log, direct) status = sys$setddir( log, , ) if( .not. status ) { call puthex( status, tstr) call putlin( "Error in setting default directory: ", ERROUT) call remark(tstr) } return end #-t- stdflt 1189 ascii 15-Jan-84 14:47:31 #-h- stdpth 318 ascii 15-Jan-84 14:47:31 ### StDPth Reset current working directory from pathname. subroutine stdpth(path) character path(ARB), temp(FILENAMESIZE), node(FILENAMESIZE) character device(FILENAMESIZE), direct(FILENAMESIZE) call gendir(path, temp) call parsef( temp, node, device, direct, temp) call stdflt( node, device, direct) return end #-t- stdpth 318 ascii 15-Jan-84 14:47:31 #-h- stmode 618 ascii 15-Jan-84 14:47:32 ### StMode Set I/O mode {COOKED|RARE|RAW} on channel `fd'. integer function stmode( fd, type) filedes fd integer type, temp integer rtopen # function(s) include io if( 1 <= fd & fd <= MAXOFILES ) { if( lfn(fd) == TTYDEVICE & type != COOKED ) { if( rtopen( filenm( 1, fd), rawchn(fd) ) == ERR ) temp = COOKED else temp = type } else temp = COOKED chtype(fd) = temp if( temp == COOKED & rawchn(fd) != NODEVICE ) # (dpm 8-Jun-81) { call sys$dassgn( %val( rawchn(fd) ) ) rawchn(fd) = NODEVICE # (dpm 8-Jun-81) } return(temp) } else return(ERR) end #-t- stmode 618 ascii 15-Jan-84 14:47:32 #-h- strhost 441 ascii 15-Jan-84 14:47:32 ### StrHost Strip host field from `buf' if same as current host. subroutine str_host( buf, temp) character buf(ARB), temp(ARB), scrat(FILENAMESIZE) integer i, junk integer equal, gtftok # function(s) if( buf(1) != '/' | buf(2) != '@@' ) # (dpm 6-Jul-81) return i = 3 junk = gtftok( buf, i, temp) call fold(temp) # (dpm 20-Nov-81) call hostnm(scrat) if( equal( scrat, temp) == YES ) call scopy( buf, i, buf, 1) return end #-t- strhost 441 ascii 15-Jan-84 14:47:32 #-h- ststat 274 ascii 15-Jan-84 14:47:32 ### StStat set status on io channel to ( OK | ERR | TMO ) integer function ststat( fd, stat) include io filedes fd integer stat if( 1 <= fd & fd <= NNFILES ) andif( stat == OK | stat == ERR | stat == TMO ) { chstat(fd) = stat return(OK) } return(ERR) end #-t- ststat 274 ascii 15-Jan-84 14:47:32 #-h- sttimo 201 ascii 15-Jan-84 14:47:33 ### StTimo Set timeout for RAW reads on io channel. subroutine sttimo( fd, sec) include io filedes fd integer sec if( 1 <= fd & fd <= NNFILES ) andif( sec >= 0 ) chtimo(fd) = sec return end #-t- sttimo 201 ascii 15-Jan-84 14:47:33 #-h- suspnd 252 ascii 15-Jan-84 14:47:33 ### Suspnd Suspend process. integer function suspnd(buf) character buf(PIDSIZE) integer pid, status integer htoi, sys$suspnd # function(s) pid = htoi(buf) status = sys$suspnd( pid, ) if( .not. status ) return(ERR) else return(OK) end #-t- suspnd 252 ascii 15-Jan-84 14:47:33 #-h- tran1 727 ascii 15-Jan-84 14:47:33 ### Tran1 Perform 1 level of logical name translation. # Return YES if translation occurred, else NO. integer function tran1( in, out) character buf1(64), buf2(64), in(100), out(100) integer dsc1(2), dsc2(2), n, status integer index, length, sys$trnlog # function(s) if( in(1) == EOS ) { out(1) = EOS return(NO) } dsc1(2) = %loc(buf1) dsc2(2) = %loc(buf2) call strcpy( in, buf1) dsc1(1) = length(buf1) dsc2(1) = 64 status = sys$trnlog( dsc1, dsc2(1), dsc2, , , ) buf2( dsc2(1) + 1 ) = 0 if( buf2(1) == 27 ) { dsc2(1) = dsc2(1) - 4 call scopy( buf2, 5, buf2, 1) } n = length(buf2) if( buf2(n) == ':' ) buf2(n) = EOS call strcpy( buf2, out) if( status == SS_NOTRAN ) return(NO) else return(YES) end #-t- tran1 727 ascii 15-Jan-84 14:47:33 #-h- trmlst 1324 ascii 15-Jan-84 14:47:34 ### TrmLst List terminals user is logged in on. integer function trmlst( user, tlist) character user(ARB), tlist(ARB) character image(FILENAMESIZE) character cmd(MAXLINE), pid(PIDSIZE), scrfil(FILENAMESIZE) character lin(MAXLINE), name(FILENAMESIZE), term(FILENAMESIZE) filedes fd filedes open # function(s) integer i, junk, tcnt, tndx integer equal, getlin, getwrd, loccom, spawn, remove # function(s) string path STD_PATH string suffix IMAGE_SUFFIX string blkgtr " >" string whostr "who" call scratf( whostr, scrfil) junk = loccom( whostr, path, suffix, image) i = 1 call stcopy( whostr, 1, cmd, i) call chcopy( ' ', cmd, i) call stcopy( user, 1, cmd, i) call stcopy( blkgtr, 1, cmd, i) call stcopy( scrfil, 1, cmd, i) if( spawn( image, cmd, pid, WAIT) == ERR ) call error("? Can't spawn ``who''") else { fd = open( scrfil, READ) if( fd == ERR ) call error("? Can't read scratch file") tcnt = 0 tndx = 1 call fold(user) while( getlin( lin, fd) != EOF ) { i = 1 call fold(lin) junk = getwrd( lin, i, term) junk = getwrd( lin, i, name) if( equal( user, name) == YES ) { if( tndx > 1 ) call chcopy( ' ', tlist, tndx) call stcopy( term, 1, tlist, tndx) tcnt = tcnt + 1 } } call close(fd) junk = remove(scrfil) } return(tcnt) end #-t- trmlst 1324 ascii 15-Jan-84 14:47:34 #-h- trnlog 592 ascii 15-Jan-84 14:47:34 ### TrnLog Tranlate (VMS) logical name from "in" to "out". integer function trnlog( in, out) character buf1(64), buf2(64), in(100), out(100) integer d1(2), d2(2), n, status integer length, sys$trnlog # function(s) d1(2) = %loc(buf1) d2(2) = %loc(buf2) call strcpy( in, buf1) d1(1) = length(in) repeat { d2(1) = 64 status = sys$trnlog( d1, n, d2, , , %val(0) ) buf2( n + 1 ) = 0 if( buf2(1) == 27 ) { n = n - 4 call scopy( buf2, 5, buf2, 1) } d1(1) = n call strcpy( buf2, buf1) } until( status == SS_NOTRAN ) call strcpy( buf1, out) return( d1(1) ) end #-t- trnlog 592 ascii 15-Jan-84 14:47:34 #-h- unique 182 ascii 15-Jan-84 14:47:34 ### Unique Get current process ID as character string in `buf'. subroutine unique(buf) character buf(ARB) integer mypid call getpid(mypid) call puthex(mypid, buf) return end #-t- unique 182 ascii 15-Jan-84 14:47:34 #-h- writef 321 ascii 15-Jan-84 14:47:35 ### WriteF Write "n" bytes from "buf" onto "fd". integer function writef( buf, n, fd) character buf(ARB) filedes fd integer n integer puts # function(s) include io if( 1 <= fd & fd <= NNFILES ) andif( lfn(fd) != NODEVICE ) andif( puts( fdb(fd), buf, n) != ERR ) return(n) return(ERR) end #-t- writef 321 ascii 15-Jan-84 14:47:35 #-h- wtmsec 465 ascii 15-Jan-84 14:47:35 ### WtMSec Wait `n' milliseconds. subroutine wtmsec(n) define( MILLISECOND, -10000) define( MAXMILLISECONDS, 1000) integer junk, m, n, timer_efn integer lib$get_ef, systim(2) # function(s) data systim(2) / -1 / , timer_efn / 0 / if( timer_efn == 0 ) junk = lib$get_ef( timer_efn ) m = max( n, 1) m = min( m, MAXMILLISECONDS) systim(1) = m * MILLISECOND call sys$setimr( %val( timer_efn ), systim, , ) call sys$waitfr( %val( timer_efn ) ) return end #-t- wtmsec 465 ascii 15-Jan-84 14:47:35 #-h- lstchr 133 ascii 15-Jan-84 14:47:35 character function lstchr(buf) character buf(ARB), c integer i c = EOS for (i=1; buf(i) != EOS; i=i+1) c = buf(i) return(c) end #-t- lstchr 133 ascii 15-Jan-84 14:47:35 #-h- dspprv 1210 ascii 15-Jan-84 14:47:36 subroutine dspprv(which_priv) character buf(arith(64,*,20)), word(20), out(MAXLINE), arg(FILENAMESIZE) integer pid, nxtcol, i, j, n, status, which_priv, k integer get_priv string blanks " " string divide " ----------------------------------@n" call getpid(pid) if (get_priv(which_priv, pid, arg, buf) == ERR) { call putlin(arg, ERROUT) call remark(": Error getting priveleges for process") } else { call inpack(nxtcol, 80, out, ERROUT) call putlin(blanks, ERROUT) call putstr(arg, -17, ERROUT) call puthex(pid, arg) call putlin(arg, ERROUT) call putch(' ', ERROUT) switch (which_priv) { case JPI_AUTHPRIV: call putlin("authpriv", ERROUT) case JPI_CURPRIV: call putlin("curpriv", ERROUT) case JPI_IMAGPRIV: call putlin("imagpriv", ERROUT) case JPI_PROCPRIV: call putlin("procpriv", ERROUT) } call putch('@n', ERROUT) call putlin(divide, ERROUT) for (i=1; buf(i) != '@n'; ) { for (j=1; buf(i) != EOS; i=i+1) call chcopy(buf(i), word, j) word(j) = EOS i = i + 1 call dopack(word, nxtcol, 80, out, ERROUT) } call flpack(nxtcol, 80, out, ERROUT) call putch('@n', ERROUT) } return end #-t- dspprv 1210 ascii 15-Jan-84 14:47:36 #-h- instal 473 ascii 15-Jan-84 14:47:36 subroutine instal(name, defn) character defn(ARB), name(ARB) integer length integer dlen, nlen include clook nlen = length(name) + 1 dlen = length(defn) + 1 if (lastt + nlen + dlen > MAX_TBL | lastp >= MAX_PTR) { call putlin(name, ERROUT) call putlnl(": too many definitions", ERROUT) return } lastp = lastp + 1 namptr(lastp) = lastt + 1 call scopy(name, 1, table, lastt+1) call scopy(defn, 1, table, lastt+nlen+1) lastt = lastt + nlen + dlen return end #-t- instal 473 ascii 15-Jan-84 14:47:36 #-h- lookup 357 ascii 15-Jan-84 14:47:37 integer function lookup(name, defn) character name(ARB), defn(ARB) integer i, j, k include clook for (i = lastp; i > 0; i = i - 1) { j = namptr(i) for (k = 1; name(k) == table(j) & name(k) != EOS; k = k + 1) j = j + 1 if (name(k) == table(j)) { call scopy(table, j+1, defn, 1) return(YES) } } return(NO) end #-t- lookup 357 ascii 15-Jan-84 14:47:37 #-t- prim.r 107995 ascii 15-Jan-84 15:26:12 #-h- rlib.inc 4841 ascii 15-Jan-84 15:26:26 #-h- carg 164 ascii 15-Jan-84 14:36:08 ## carg common block # Put on a file called 'carg' # Used by osprim.r common /carg/ nbrarg, ptr(MAXARGS), arg(ARGBUFSIZE) integer nbrarg, ptr character arg #-t- carg 164 ascii 15-Jan-84 14:36:08 #-h- cast 105 ascii 15-Jan-84 14:36:08 ## CAST -- Common block for ^C AST flag. common / cast / gotast integer gotast # YES => AST received. #-t- cast 105 ascii 15-Jan-84 14:36:08 #-h- cdirec 285 ascii 15-Jan-84 14:36:09 common / cdirec / dfab(NDIRECTS), dnam(FILENAMESIZE, NDIRECTS), lfile(FILENAMESIZE, NDIRECTS) integer dfab # fab address for directory manipulations character dnam # DEC string for directory - used to get aux info character lfile # last file string returned by gdrprm #-t- cdirec 285 ascii 15-Jan-84 14:36:09 #-h- cexith 195 ascii 15-Jan-84 14:36:09 # common block for exit handler on VAX/VMS # common / cexith / desblk(4), reason integer desblk # descriptor block argument for sys$dclexh integer reason # integer to store reason for exit #-t- cexith 195 ascii 15-Jan-84 14:36:09 #-h- clook 248 ascii 15-Jan-84 14:36:09 common / pr_clook / lastp, lastt, namptr(MAX_PTR), table(MAX_TBL) integer lastp # last used pointer, init=0 integer lastt # last used table, init=0 integer namptr # pointers to name/defn pairs character table # storage for name/defn pairs #-t- clook 248 ascii 15-Jan-84 14:36:09 #-h- cproc 564 ascii 15-Jan-84 14:36:09 common / cproc / n4grnd, spunit, pdone(NPROCESSES), pmsg(TERMSGSIZE, NPROCESSES), mbxchn(NPROCESSES), pid(PIDSIZE, NPROCESSES), pname(FILENAMESIZE, NPROCESSES) integer n4grnd # number of active foreground tasks integer spunit # unit for reporting status of background processes integer pdone # is process done? YES/NO integer pmsg # termination mailbox message goes here integer mbxchn # channel for mailbox used for arguments character pid # string with pid for this process character pname # name of image which process is running #-t- cproc 564 ascii 15-Jan-84 14:36:09 #-h- cquota 292 ascii 15-Jan-84 14:36:10 # common block to hold quota list for creprc system service common / cquota / b1, l1, b2, l2, b3, l3, b4, l4, b5, l5, b6, l6, b7, l7, b8, l8, b9, l9, ba, la, bb, lb, b0 character b1, b2, b3, b4, b5, b6, b7, b8, b9, ba, bb, b0 integer l1, l2, l3, l4, l5, l6, l7, l8, l9, la, lb #-t- cquota 292 ascii 15-Jan-84 14:36:10 #-h- ctrmbx 364 ascii 15-Jan-84 14:36:10 # common block ctrmbx - contains information used in VAX termination # mailbox scheme # place on a file called ctrmbx # used by osprim.r and spawn.r common / ctrmbx / termbx, iosb(2), termsg(TERMSGSIZE) integer termbx # channel for termination mail box integer iosb # io status block for process id integer termsg # buffer to receive termination status #-t- ctrmbx 364 ascii 15-Jan-84 14:36:10 #-h- io 1418 ascii 15-Jan-84 14:36:10 ## io -- common block with VMS and IAS io info for tools # put on a file called 'io' # Used by osprim.r common / io / lfn(NNFILES), lastc(NNFILES), fdb(NNFILES), rawchn(NNFILES), bcount(NNFILES), chstat(NNFILES), chtimo(NNFILES), imp_ctrl(NNFILES), mode(NNFILES), filacc(NNFILES), fltype(NNFILES), chtype(NNFILES), filenm(FILENAMESIZE, NNFILES), buffer(MAXLINE, NNFILES), new_versions integer lfn # ascii device name; initialized to TI integer lastc # pointer to last character in unit's buffer # initialized to 0 for output, MAXLINE for input integer fdb # fdb address for unit; initialized in open subs integer rawchn # VMS channel to use for raw IO integer bcount # size of current record we are reading integer chstat # status on unit integer chtimo # timeout value for raw reads logical*1 imp_ctrl # if implied carriage control is necessary YES/NO logical*1 mode # array for mode of input - INPUTMODE/OUTPUTMOODE logical*1 filacc # access used to open file logical*1 fltype # type of file - BINARY/ASCII logical*1 chtype # type of channel - RAW/COOKED character filenm # file name associated with unit character buffer # line buffer for unit integer new_versions # YES/NO whether to create a new version when # creating a file at WRITE access #-t- io 1418 ascii 15-Jan-84 14:36:10 #-t- rlib.inc 4841 ascii 15-Jan-84 15:26:26 #-t- rlib.ar 337387 ascii 15-Jan-84 15:29:20