;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