Artifact 5f1506948cd99f9b7f19b77d4a478ac3cd12e2ef9ab9b796524d974d3a0dc4d8:
- File
psl-1983/20-kernel/tags.fai
— part of check-in
[eb17ceb7f6]
at
2020-04-21 19:40:01
on branch master
— Add Reduce 3.0 to the historical section of the archive, and some more
files relating to version sof PSL from the early 1980s. Thanks are due to
Paul McJones and Nelson Beebe for these, as well as to all the original
authors.git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 22700) [annotate] [blame] [check-ins using] [more...]
;MRC:<EMACS>TAGS.FAI.49, 10-Sep-81 12:22:29, Edit by ADMIN.JQJ ;add dummy SCRIBE routine. title tags search monsym subttl Definitions ifndef tnxsw,< ife .osfail-<sixbit /TENEX/>,< tnxsw __ -1>> ifndef tnxsw,< tnxsw __ 0> t20sw __ tnxsw define tnx <ifn tnxsw> define t20 <ifn t20sw> tnx,< prints \TENEX version. \ opdef pstin [jsys 611] > t20,< prints \TOPS-20 version. \> f_0 ; Flags t_7 ; Temp u_10 ; Temp s_11 ; String and temp s1_12 ; Second part for string n_13 ; Counter of functions found ch_14 ; Character l_15 ; Language type bp_16 ; Byte pointer p_17 ; Guess ; LH flags f%f1 __ 400000 ; Temp flags f%f2 __ 200000 ; RH flags f%oldf __ 400000 ; Using old tags file, not making one f%eoff __ 200000 ; EOF seen on old file f%lgvn __ 100000 ; Language specified by user with / opdef call [pushj p, 0] opdef ret [popj p, 0] opdef uerr [1b8] define error (x) < uerr [asciz /x/] > loc 41 call uuoh reloc subttl Impure storage tagjfb: block 2 ; Flags and jfns block 3 ; Device, dir, name point 7, [asciz /TAGS/] ; Extension block 4 injfn: 0 tagjfn: 0 oldjfn: 0 nfiles: 0 nfunct: 0 nchars: 0 filptr: 0 hdrptr: 0 zroptr: 0 indefq: 0 ; Non-zero => inside DEFINEQ for INTERLISP nparen: 0 ; <paren depth> - 1 for INTERLISP arpdp: 0 ; Pushdown pointer for [] paren pdl parpdl: block 100 ; Stack itself defext: block 10 strbsz __ 100 strbuf: block strbsz npdl __ 17 pdl: block npdl subttl Pure storage defjfb: gj%old!gj%cfm!gj%ifg!gj%xtn .priin,,.priou block 3 point 7, defext block 3 3 block 2 point 7, [asciz /*/] minus1:: zromsk: byte (7) 177, 177, 177, 177, 177 (1) 1 byte (7) 000, 177, 177, 177, 177 (1) 1 byte (7) 000, 000, 177, 177, 177 (1) 1 byte (7) 000, 000, 000, 177, 177 (1) 1 byte (7) 000, 000, 000, 000, 177 (1) 1 crlf: byte (7) 15, 12, 0 squozp: repeat "#"-0+1,<0> ; ^@ - # repeat "%"-"$"+1,<-1> ; $ - % repeat "-"-"&"+1,<0> ; & - - repeat "."-"."+1,<-1> ; . repeat "/"-"/"+1,<0> ; / repeat "9"-"0"+1,<-1> ; 0 - 9 repeat "@"-":"+1,<0> ; : - @ repeat "Z"-"A"+1,<-1> ; A - Z repeat "`"-"["+1,<0> ; [ - ` repeat "z"-"a"+1,<-1> ; a - z repeat 177-"{"+1,<0> ; { - rubout subttl Languages we know about ;lang(language name, default extension, dispatch tag prefix) ;The maximum length of the default extension is 5 characters. define langs < lang(BLISS,BLI,BLI) lang(BLISS11,B11,B11) lang(FAIL,FAI,FAI) lang(FORTRAN,FOR,FOR) lang(H316,H16,H16) lang(INTERLISP,ILSP,LSP) lang(MACLISP,LSP,MCL) lang(MACN11,M11,M11) lang(MACRO,MAC,MAC) lang(MIDAS,MID,MID) lang(PAL11X,P11,P11) lang(PSL,SL,SL) ; "Portable Standard Lisp" or "Standard Lisp" lang(REDUCE,RED,RED) ; Reduce and Rlisp files. lang(SAIL,SAI,SAI) lang(SCRIBE,MSS,SCR) lang(TECO,EMACS,TEC) > ; Indexes for languages define lang ' (x,y,z) < lt.'z __ nlangs nlangs __ nlangs+1 > nlangs __ 0 langs ; Table of filename extensions define lang ' (x,y,z) < <asciz /y/> > langex: langs ; Table of language names define lang(x,y,z) < [asciz /x/] > langtb: langs ; Table of dispatch routines for them define lang ' (x,y,z) < z'lin > langds: langs subttl Hairy string macro ; Reset string define strini (str) { define str {0,} } define strcn1 ' (str,str2,dummy,str1) { define str {0,str1'str2} } ; Add str2 to str1's current value define strcnc (str1,str2) { strcn1 (str1,str2,\str1) } define strget ' (ac,cond,dummy,str) { ifdif {str},{},{cam'cond ac, [ascii /str/]} ifidn {str},{},{cai'cond ac, 0} } ; Get the resultant string define strevl (ac,cond,str) { strget (ac,cond,\str) } ; Go to jmp if string in s and s1 matches str ; Or if jmp not spec, return unless matches define strmat (str, jmp) { strini(str1) strini(str2) strcnt __ 0 for char e {str} { ifl strcnt-5,{ strcnc(str1,char)} ifge strcnt-5,{ strcnc(str2,char)} strcnt __ strcnt+1 } purge strcnt strevl(s,n,str1) strevl(s1,e,str2) ifidn {jmp},{},{ret} ifdif {jmp},{},{caia jrst jmp} } subttl Main program go: reset setzb f, nfiles move p, [iowd npdl, pdl] call dorscn ; Check for filename in rscan line call filini ; Get output file hrroi 1, [asciz / Type filenames, end with blank line /] trnn f, f%oldf psout ; Unless using old file, give prompt setzm injfn ; Make sure we dont thing there's a file floop: call nxtfil ; Get the next file to do jrst done ; All done call inifil ; Set up to start this file lloop: call nxtlin ; Get the next line jrst lloopf ; End of this file call @langds(l) ; Do this line jrst lloop lloopf: call finfil ; Finish up this file jrst floop done: call finish ; Finish up the output tags file haltf jrst go subttl Top level subroutines ; Get command line dorscn: trz f, f%oldf ; Clear out flag t20,< setz 1, rscan tdza 1, 1 jumpe 1, cpopj ; No command line movni 3, (1) movei 1, .cttrm hrroi 2, strbuf sin ; Read command line move bp, [point 7, strbuf] dorsc1: ildb 1, bp cain 1, 12 ; EOL? ret ; Yes, return to get from tty caie 1, " " ; Space? jrst dorsc1 ; No, keep going > tnx,< movei 1, .priin bkjfn jfcl pbin ; Get terminator of command line caie 1, " " ret ; Return if not space to get from tty > ; Get file from command line t20,< dmove 1, [gj%old .nulio,,.nulio] dmovem 1, tagjfb movei 1, tagjfb ; Default to .TAGS move 2, bp > tnx,< movsi 1, (gj%old!gj%cfm!gj%msg) movem 1, tagjfb move 1, [.priin,,.priou] movem 1, tagjfb+.gjsrc movei 1, tagjfb setz 2, > gtjfn jrst dorscx move 2, [7b5+of%rd] openf jrst dorscx movem 1, oldjfn ; And save jfn of old file tro f, f%oldf ret dorscx: call jerror ; Print jsys error message haltf jrst go ; Set up output file filini: setzm defext ; Reset default extension trne f, f%oldf ; If reparsing, jrst filin2 ; Get next version of old file filin1: hrroi 1, [asciz / Output tags file: /] psout t20,< dmove 1, [gj%fou!gj%cfm!gj%msg .priin,,.priou] dmovem 1, tagjfb > tnx,< movsi 1, (gj%fou!gj%cfm!gj%msg) movem 1, tagjfb move 1, [.priin,,.priou] movem 1, tagjfb+.gjsrc > movei 1, tagjfb setz 2, gtjfn jrst filix1 move 2, [7b5+of%wr] ; Open for write openf jrst filix1 movem 1, tagjfn ret filin2: hrroi 1, strbuf move 2, oldjfn ; Name of old file move 3, [111100,,1] ; DEV:<DIR>NAM.EXT (no gen number) jfns movsi 1, (gj%fou!gj%sht) hrroi 2, strbuf gtjfn jrst filix2 move 2, [7b5+of%wr] openf jrst filix2 movem 1, tagjfn ret filix1: call jerror jrst filin1 ; Try again filix2: call jerror haltf jrst filini ; Get the next file to process nxtfil: trne f, f%oldf ; If from old file jrst nxtfl2 ; Read next one from that file nxtfl0: skipe 1, injfn ; See if more in this filespec gnjfn jrst nxtfl1 ; Nope andi 1, -1 move 2, [7b5+of%rd] openf jrst nxtfl0 aos (p) ; Will skip return trne f, f%lgvn ; If got language from user with /, ret ; Use it again, else jrst nxtf1e ; Try to match from extension nxtfl1: movei 1, "*" pbout ; Prompt movei 1, defjfb ; String with last default in it setz 2, gtjfn jrst nxtfx1 movem 1, injfn andi 1, -1 move 2, [7b5+of%rd] openf jrst nxtfx1 aos (p) ; Will skip return trz f, f%lgvn ; Reset language from user flag movei 1, .priin ; Get confirming char bkjfn ret pbin caie 1, "/" ; Was it a slash? jrst nxtf1e ; No, get language from extension tro f, f%lgvn ; Say language was given by user jrst getlng ; Get language from user and return nxtf1e: setz s, hrroi 1, s hrrz 2, injfn movsi 3, 000100 ; Just file type jfns movsi l, -nlangs ; Pointer for language options nxtf1f: came s, langex(l) ; Extension matches? aobjn l, nxtf1f ; No, keep trying jumpge l, getlnx ; If not found, go ask for it ret ; Else return nxtfx1: cain 1, gjfx33 ; Filename not spec? ret ; Yes, single return call jerror jrst nxtfl1 nxtfl2: trne f, f%eoff ; EOF last time ret ; Yes, single return this time then aos (p) ; Else prepare for skip return movsi 1, (gj%old!gj%fns!gj%sht) movei 2, .nulio hrl 2, oldjfn ; Source if old file gtjfn jrst nxtfx2 move 2, [7b5+of%rd] openf jrst nxtfx2 movem 1, injfn move 1, oldjfn ; Find language type in file nxtf2a: bin caie 2, "," ; Find the comma jrst nxtf2a setzm strbuf setzm strbuf+1 hrroi 2, strbuf movei 3, strbsz*5 movei 4, 15 ; Until CR sin setz 3, dpb 3, 2 ; Mark end of line with null nxtf2b: bin jumpe 2, nxtf2z ; Maybe EOF caie 2, 37 ; Find the ^_ jrst nxtf2b bin caie 2, 15 ; Followed by CRLF jrst nxtf2b bin caie 2, 12 jrst nxtf2b bin ; Peek next char bkjfn trn skipn 2 ; See if EOF now nxtf2c: tro f, f%eoff ; Yes, say so jrst getln2 ; Lookup language name nxtfx2: call jerror haltf jrst nxtfil nxtf2z: gtsts tlnn 2, (gs%eof) ; EOF? jrst nxtf2b ; No jrst nxtf2c ; Init variables for this file, etc. inifil: move 1, tagjfn ; Output file rfptr ; Get current position seto 2, movem 2, hdrptr ; Save pointer to start of this header hrrz 2, injfn move 3, [111100,,1] ; DEV:<DIR>NAM.EXT jfns t20,< hrroi 2, [asciz /.0 00000,/] > tnx,< hrroi 2, [asciz /;0 00000,/] > setz 3, sout rfptr ; Get current position in file seto 2, subi 2, 6 ; Position just before 1st of 0's movem 2, zroptr ; Save it for later andi l, -1 ; Clear any index hrro 2, langtb(l) ; Get language name sout hrroi 2, crlf sout setzb n, filptr ; Reset counters setzm nchars aos nfiles ; Count one more file cpopj: ret ; Get the next line nxtlin: move 1, nchars ; Get number of chars from last time addm 1, filptr ; Update current position in file hrrz 1, injfn hrroi 2, strbuf movei 3, strbsz*5 movei 4, 12 ; Read till LF sin subi 3, strbsz*5 ; Get number of characters read jumpe 3, cpopj ; None, EOF then movnm 3, nchars ; Save number of characters read move bp, [point 7, strbuf] cpopj1: aos (p) ret ; Skip return ; Finish up the current file finfil: move 1, tagjfn ; Output file hrroi 2, [byte (7) 37, 15, 12, 0] ; ^_CRLF setz 3, sout rfptr ; Get current position now setz 2, sub 2, hdrptr ; Less start of this block push p, 2 ; Save it move 2, zroptr ; Start of zero block sfptr error (SFPTR failed) pop p, 2 move 3, [no%lfl+no%zro+5b17+=10] ; Size in decimal nout trn seto 2, ; Back to then end now sfptr error (SFPTR failed) hrrz 2, injfn trne f, f%oldf ; If getting from the tty, jrst finfl2 hrroi 1, defext movsi 3, 000100 ; Set the default type for next time jfns finfl2: movei 1, .priou ; Tell the user what is happenning setz 3, jfns hrroi 2, [asciz / - /] sout movei 2, (n) ; Number of functions written movei 3, =10 nout trn hrroi 1, [asciz /. functions found. /] psout addm n, nfunct ; Keep track of grand totals move 1, injfn tlnn 1, (gj%dev!gj%dir!gj%nam!gj%ext) ; Wildcards given? tlza 1, -1 ; No, clear random bits hrli 1, (co%nrj) ; Yes, keep the jfn then for next time closf ; Done with the file trn ret ; Finish up everything finish: movei 1, .priou move 2, tagjfn ; Output file setz 3, jfns hrroi 2, [asciz / - /] sout movei 3, =10 move 2, nfunct ; Number of functions done nout trn hrroi 1, [asciz /. functions in /] psout movei 1, .priou move 2, nfiles ; Number of files used nout trn hrroi 1, [asciz /. files. /] psout move 1, tagjfn closf ; Close the output file trn ret subttl Lower level subroutines ; Get the language type getlnx: hrroi 1, [asciz /? Language type not recognised Please specify for /] psout movei 1, .priou hrrz 2, injfn setz 3, jfns hrroi 1, [asciz / : /] psout getlng: hrroi 1, strbuf t20,< move 2, [rd%rai+rd%crf+strbsz*5] setz 3, rdtty error (RDTTY failed) > tnx,< movei 2, strbsz*5 pstin > andi 2, -1 ; Get number of chars used subi 2, strbsz*5-1 ; Clear terminator too movm 2, 2 idivi 2, 5 ; Get number of words used move 3, zromsk(3) andcam 3, strbuf(2) setzm strbuf+1(2) ; Clear next word for good measure getln2: t20,< dmove s, strbuf ; Get first two words of string > tnx,< move s, strbuf move s1, strbuf+1 > movsi l, -nlangs camn s, [asciz /?/] jumpe s1, getln5 ; Try to help the guy out if he asks getln3: hrrz 2, langtb(l) came s, (2) ; First word matches? jrst getln4 ; No jumpe s1, cpopj ; If only one word, matched camn s1, 1(2) ret ; Found it. getln4: aobjn l, getln3 jrst getlnx ; Not found getln5: hrroi 1, [asciz / one of: /] psout getln6: hrro 1, langtb(l) psout hrroi 1, crlf psout aobjn l, getln6 jrst getlnx ; Write out line before the current LF outtlf: add bp, [7b5] skipge bp sub bp, [43b5+1] ldb ch, bp ; Get char before LF cain ch, 15 ; Is it CR? add bp, [7b5] ; Yes, back over it too ; Write out the beginning of the current line and the current position ; To the tags output file outtag: setz 3, idpb 3, bp ; Mark end with a null move 1, tagjfn ; Output file hrroi 2, strbuf sout ; Write out start of line movei 2, 177 ; And rubout bout movei 2, -strbuf(bp) ; Get number of words imuli 2, 5 ; Into characters ldb 3, [point 6, bp, 5] ; Get current position idivi 3, 7 subi 3, 4 sub 2, 3 ; Get current position add 2, filptr ; Make it absolute movei 3, =10 ; Decimal nout trn hrroi 2, crlf setz 3, sout ; And CRLF aoj n, ; Count another one done ret ; Error handler uuoh: movei 1, "?" pbout hrro 1, 40 psout haltf ret ; Print JSYS error message jerror: movei 1, "?" pbout movei 1, .priou hrloi 2, .fhslf setz 3, erstr trn trn hrroi 1, crlf psout ret subttl Language dependant subroutines ; Assembly language subroutines failin: m11lin: maclin: midlin: p11lin: h16lin: asmlin: setzb t, s asmln0: ildb ch, bp ; Get first character cain ch, "L"-100 ; Allow formfeed jrst asmln0 caie ch, "" ; For fail, cain ch, "^" ; Allow arrows at start of line caie l, lt.fai jrst asmln2 jrst asmln0 ; So get another char asmln1: movei t, (ch) ; Save previous char ildb ch, bp asmln2: skipe squozp(ch) ; Is this legal squoze char? aoja s, asmln1 ; Yes, keep looking asmln3: caie ch, ":" ; If it's a : or cain ch, "=" ; =, jrst asmln4 ; We found one maybe caie l, lt.fai ; For fail cain l, lt.p11 ; Or pal11x, caia ret cain ch, "_" ; Allow _ too jrst asmln4 caie ch, 11 ; And tabs before the :'s cain ch, " " ; Or spaces caia ret ; Else no tag here ildb ch, bp ; Get another char and try it jrst asmln3 asmln4: caie l, lt.m11 ; For MACN11 ... cain l, lt.p11 ; Or pal11x ... jrst asmln6 ; Check for local labels asmln5: jumpe s, cpopj ; = isnt a label (as in =24 for fail) cain t, "." ; If label is not just dot caie s, 1 jrst outtag ; Found one ret asmln6: move t, [point 7, strbuf] ; Start of line again asmln7: ildb ch, t cain ch, "L"-100 ; Dont be confused by ff jrst asmln7 cail ch, "0" ; See if it is a digit caile ch, "9" jrst asmln5 ; It isnt ret ; It is, flush it ; SCRIBE subroutine (null for now) scrlin: ret ; TECO subroutine teclin: ildb ch, bp ; Get first character caie ch, "!" ; Only lines starting with ! pass ret setz s, ; Reset found pointer tecln1: ildb ch, bp ; Get next character cain ch, 12 ; End of line jrst tecln2 ; Go see if we found anything caie ch, ":" ; Must have had : just before a ! jrst tecln1 ildb ch, bp ; Get next char cain ch, "!" move s, bp ; If label, save the current pointer jrst tecln1 tecln2: skipn bp, s ; Get last label we had ret ; None found jrst outtag ; And output that many ; SAIL subroutine sailin: call ratom ; Get the first word strmat SIMPLE, sailin strmat RECURSIVE, sailin strmat BOOLEAN, sailn3 strmat INTEGER, sailn3 strmat REAL, sailn3 strmat STRING, sailn3 sailn1: strmat PROCEDURE setz s, ; Reset paren level sailn2: ildb ch, bp ; Get a char cain ch, 12 ; If end of line jrst outtlf ; Write the whole line then cain ch, "(" ; Count one more left paren aoja s, sailn2 cain ch, ")" ; Count one less paren soja s, sailn2 cain ch, ";" ; Now, if to the ; jumple s, outtag ; Output it if not inside parens jrst sailn2 ; Else keep going sailn3: call ratom ; Get another word jrst sailn1 ; And try it ; Bliss subroutines b11lin: blilin: call ratom ; Get word strmat GLOBAL, bliln3 bliln1: strmat ROUTINE, bliln2 caie l, lt.bli ; Bliss-10 has FUNCTIONS too ret ; Not a function decl strmat FUNCTION bliln2: ildb ch, bp ; Get chars caie ch, "=" ; Until = cain ch, 12 ; Or end of this line jrst outtag jrst bliln2 bliln3: call ratom jrst bliln1 ; Fortran subroutine forlin: call ratom ; Get a word strmat PROGRAM,forln1 strmat SUBROUTINE,forln1 strmat DOUBLE,forln6 forln4: strmat INTEGER,forln7 strmat REAL,forln7 strmat COMPLEX,forln7 forln5: strmat FUNCTION forln1: ildb ch, bp ; Get a character cain ch, 12 ; If eol here, jrst outtlf ; Use whole line caie ch, "(" ; Look for start of args jrst forln1 forln2: movei s, 1 ; Init paren level forln3: ildb ch, bp ; Get character cain ch, 12 ; If eol, jrst outtlf ; Write whole line cain ch, "(" ; Keep track of paren level aoja s, forln3 cain ch, ")" ; And look for matching close sojle s, outtag jrst forln3 forln6: call ratom jrst forln4 forln7: call ratom jrst forln5 ; MACLISP subroutines mcllin: for zot e {(DEF} ; Do all lines that begin with (DEF { ildb ch, bp caie ch, "zot" ifg "zot"-100,{ cain ch, "zot"+40 caia } ret } movei u, 1 mclln1: ildb ch, bp cain ch, 12 jrst outtlf caie ch, " " jrst mclln1 sojge u, mclln1 jrst outtag ; INTERLISP routines lsplin: skipe indefq ; Already inside a DEFINEQ? jrst lspln1 ; Yes, see if this is a new form call ratom ; Else get the beginning of the line strmat {(DEFINEQ} ; And try for start of new one setom indefq ; Remember are inside one setzm nparen ; And initialize paren depth move t, [iowd 100, parpdl] ; Initialise bracket pdl lspln0: movem t, parpdp lspln1: ildb ch, bp ; Get next character cain ch, 12 ; End of line? ret cain ch, "%" ; Char quoted? jrst [ildb ch, bp ; Yes, just gobble one jrst lspln1] cain ch, "[" ; Super open paren jrst lspln4 cain ch, "]" ; Super close jrst lspln5 cain ch, "(" ; Go down a level jrst lspln2 cain ch, ")" ; Close one level of parens sosl nparen ; And see if this finishes the DEFINEQ jrst lspln1 ; Doesnt, get next character setzm indefq ; No longer inside a DEFINEQ ret ; Rest of this line no good to us lspln4: exch t, parpdp ; [ - save the curren paren depth push t, nparen exch t, parpdp ; And fall thru for one more open lspln2: aos t, nparen caie t, 1 ; Start of a new definition within the defineq? jrst lspln1 ; No, keep trying lspln3: ildb ch, bp ; Get next character cain ch, 12 ; End of line is end of atom of functions name jrst outtlf cain ch, " " ; Or a space also jrst outtag ; Yes, output this line then jrst lspln3 ; Keep looking lspln5: move t, parpdp ; ] - restore from last ] pop t, nparen jrst lspln0 ; And continue ; PSL routines ; Portable Standard Lisp (PSL) handler (simple minded version). Also ; handles other Utah flavors of Lisp. sllin: call ratom strmat {(DE},sl1 ; Look for one of "(DE", (Define Expr), strmat {(DF},sl1 ; "(DF", (Define Fexpr), strmat {(DM},sl1 ; "(DM", (Define Macro), strmat {(DN},sl1 ; "(DN", (Define Nexpr), strmat {(DS},sl1 ; "(DS", (Define Substitution Macro), strmat {(DEFUN},sl1 ; "(DEFUN", (Define Expr), strmat {(DEFVAR},sl1 ; "(DEFVAR", (Define fluid variable), strmat {(DEFCONST},sl1 ; "(DEFCONST", (Define constant), strmat {(LAP},sl1 ; "(LAP", ("Lisp Assembler Program"?) ; Might be better to look for "!*entry" ? strmat {(DEFMACRO},sl1 ; "(DEFMACRO", (an alternate way to define ; macros) strmat {(DEFFLAVOR},sl1 ; "(DEFFLAVOR", (Define Flavor), strmat {(DEFMETHOD} ; "(DEFMETHOD", (Define Method) sl1: ; Write the tag out ildb ch, bp ; Scan for end of line. cain ch, 12 ; (I.e. End of Line) jrst outtlf ; Write the line if EOL seen jrst sl1 ; Keep looping till found ; REDUCE subroutine redlin: call Satom ; Get the first word strmat SYMBOLIC, redlin ; ftypes (of REDUCE) strmat ALGEBRAIC, redlin strmat BOOLEAN, redlin strmat INTEGER, redlin strmat FEXPR, redlin strmat EXPR, redlin strmat LISP, redlin strmat MACRO, redlin strmat SMACRO, redlin strmat NMACRO, redlin strmat SYSLSP, redlin strmat LAP, redn2 ; Might be better to look for !*entry ? strmat MODE, redn2 strmat GLOBAL, redn1 redn1: strmat PROCEDURE setz s, ; Reset paren level jrst sailn2 redn2: ildb ch,bp ; get chars cain ch,"=" ; Until = jrst outtag cain ch,12 ; or until the end of line jrst outtlf jrst redn2 ; A hacked-up version of ratom to allow reading "RECORD!POINTER" ; Read the next word into s and s1 Satom: ildb ch, bp ; Get a character cain ch, 12 ; If end of line here jrst Satom3 ; Return to callers caller caie ch, " " ; Flush white space cain ch, 11 jrst Satom cain ch, "L"-100 ; Or ff jrst Satom setzb s, s1 move t, [point 7, s] movei u, =10 ; Max number of chars Satom1: caie ch, "!" cain ch, "" jrst satom ; Start over if "!" or "^X" cail ch, "a" caile ch, "z" caia trz ch, "a"-"A" ; Uppercase it idpb ch, t ildb ch, bp cain ch, "(" movei ch, " " ; Change "(" to space caile ch, " " ; Until terminator sojg u, Satom1 jumple u, Satom3 ; Too long for us add bp, [7b5] ; Back up over teminator ret ; And return Satom3: pop p, garb# ; Flush callers return ret ; And return to callers caller ; Read the next word into s and s1 ratom: ildb ch, bp ; Get a character cain ch, 12 ; If end of line here jrst ratom3 ; Return to callers caller caie ch, " " ; Flush white space cain ch, 11 jrst ratom cain ch, "L"-100 ; Or ff jrst ratom setzb s, s1 move t, [point 7, s] movei u, =10 ; Max number of chars ratom1: cail ch, "a" caile ch, "z" caia trz ch, "a"-"A" ; Uppercase it idpb ch, t ildb ch, bp caile ch, " " ; Until terminator sojg u, ratom1 jumple u, ratom3 ; Too long for us add bp, [7b5] ; Back up over teminator ret ; And return ratom3: pop p, garb# ; Flush callers return ret ; And return to callers caller ; Local modes: ; Mode: FAIL ; Comment col:40 ; Comment start:; ; End: end go