Trailing-Edge
-
PDP-10 Archives
-
mit_emacs_170_teco_1220
-
emacs/tags.fai
There are no other files named tags.fai in the archive.
;SIERRA:<EMACS162>TAGS.FAI.52, 1-Sep-84 07:22:45, Edit by BRADFORD
; Merged version from MIT-XX and SU-SIERRA
;SX:<EMACS162>TAGS.FAI.50, 25-Mar-82 01:12:37, Edit by K.KANEF
; No default extension for first file, instead of defaulting to null extension.
; (DEFJFB+.GJEXT starts as 0, then later points to DEFEXT.
; Moved DEFJFB to impure storage)
;MRC:<EMACS>TAGS.FAI.49, 10-Sep-81 12:22:29, Edit by ADMIN.JQJ
;add dummy SCRIBE routine.
; <KLOTZ>TAGS.FAI.16, 5-Aug-82 01:28:00, Edit by KLOTZ@MIT-OZ
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.
\
.insert monsym
opdef pstin [jsys 611]
>
t20,< prints \TOPS-20 version.
\
search monsym
>
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
defjfb: gj%old!gj%cfm!gj%ifg!gj%xtn
.priin,,.priou
block 3
0
block 3
3
block 2
point 7, [asciz /*/]
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
parpdp: 0 ; Pushdown pointer for [] paren pdl
parpdl: block 1000 ; [PJG] Stack itself, orig. 100
defext: block 10
strbsz __ 500 ; [PJG] Used to be 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(BASIC,B20,B20)
lang(BLISS,BLI,BLI)
lang(BLISS11,B11,BLI)
lang(FAIL,FAI,ASM)
lang(FORTRAN,FOR,FOR)
lang(GYPSY,GYP,PAS)
lang(H316,H16,ASM)
lang(INTERLISP,ILSP,LSP)
lang(MACLISP,LSP,MCL)
lang(MACN11,M11,ASM)
lang(MACRO,MAC,ASM)
lang(MIDAS,MID,ASM)
lang(MORTRAN,MOR,MOR)
lang(NONE,ZZZ,ZZZ)
lang(PAL11X,P11,ASM)
lang(PASCAL,PAS,PAS)
lang(PASCAL,PGO,PAS)
lang(PCL,PCL,PCL)
lang(PUB,DFS,DFS)
lang(PUBTEXT,PUB,PUB)
lang(SAIL,SAI,SAI)
lang(SCRIBE,MSS,SCR)
lang(TECO,EMACS,TEC)
lang(TECO,TEC,TEC)
lang(TEXT,DOC,TXT)
lang(TEXT,HLP,TXT)
lang(TEXT,MEM,TXT)
lang(TEXT,TXT,TXT)
lang(UNKNOWN,ZZ0,ZZZ)
>
; 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
move 1,[sixbit \TAGS \]
setnm
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 defjfb+.gjext ; 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
move 1, [point 7, defext]
movem 1, defjfb+.gjext
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
; NULL Language type include TEXT and NONE
zzzlin:
txtlin: aos (p) ; [PJG] Just return and jump
ret
; Assembly language subroutines
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
; PASCAL subroutine
paslin: call ratom
strmat PROCEDURE, pas1
strmat FUNCTION
pas1: setz s,
jrst sailn2
; 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
strmat INTERNAL, sailn3
strmat EXTERNAL, 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
; PCL subroutine
pcllin: call ratom ; Get the first word
strmat INTEGER, pclln3
strmat STRING, pclln3
strmat COMMAND,pclset
pclln1: strmat PROCEDURE
pclset: setz s, ; Reset paren level
pclln2: 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, pclln2
cain ch, ")" ; Count one less paren
soja s, pclln2
cain ch, ";" ; Now, if to the ;
jumple s, outtag ; Output it if not inside parens
jrst pclln2 ; Else keep going
pclln3: call ratom ; Get another word
jrst pclln1 ; And try it
; Bliss subroutines
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 ENTRY,forln1
strmat OVERLAY,forln1
strmat BLOCK,forln8
strmat DOUBLE,forln6
forln4: strmat INTEGER,forln7
strmat REAL,forln7
strmat COMPLEX,forln7
strmat LOGICAL,forln7
forln5: strmat FUNCTION,forln1
ret ; [PJG] If none of these then return
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
strmat PRECISION,forln5
ret
forln7: call ratom
jrst forln5
forln8: call ratom
strmat DATA,forln1
ret
; Pub text subroutine
publin: ildb ch,bp ; [PJG] Get a character
cain ch,14 ; ignore formfeeds
jrst publin
caie ch,"." ; [PJG] If a period then command line
ret ; [PJG] If none then return
publn0: call ratom
strmat RECURSIVE,publn0
strmat ABSTRACT,publn1
strmat ACKNOWLEDGMENTS,publn1
strmat APPENDIX,publn1
strmat COPYRIGHT,publn1
strmat MACRO,publn1
strmat OMITSEC,publn1
strmat S5,publn1 ; [PJG] Extended sections
strmat S6,publn1 ; [PJG] Extended sections
strmat SEC,publn1
strmat SIGNATUREP,publn1
strmat SS,publn1
strmat SSS,publn1
strmat SSSS,publn1
strmat TITLEPAGE,publn1
ret
; Pub subroutine
dfslin: ildb ch,bp ; [PJG] Get a character
cain ch,14 ; ignore formfeeds
jrst dfslin
caie ch,"." ; [PJG] If a period then command line
ret ; [PJG] If none then return
dfsln0: call ratom
strmat RECURSIVE,dfsln0
strmat MACRO,publn1
ret
publn1: ildb ch, bp ; Get a character
cain ch, 12 ; If eol here,
jrst outtlf ; Use whole line
caiN ch, "$" ; If dollar
jrst outtlf ; Use whole line
caie ch, "(" ; Look for start of args
jrst publn1
publn2: movei s, 1 ; Init paren level
publn3: ildb ch, bp ; Get character
cain ch, 12 ; If eol,
jrst outtlf ; Write whole line
cain ch, "(" ; Keep track of paren level
aoja s, publn3
cain ch, ")" ; And look for matching close
sojle s, outtag
jrst publn3
; Mortran subroutine
morlin: call ratom ; Get a word
strmat SUBROUTINE,morln1
strmat PROCEDURE,morln1
morln4: strmat INTEGER,morln7
strmat REAL,morln7
strmat COMPLEX,morln7
strmat LOGICAL,morln7
strmat STRING,morln7
morln5: strmat FUNCTION,morln1
ret
morln1: ildb ch, bp ; Get a character
cain ch, 12 ; If eol here,
jrst outtlf ; Use whole line
cain ch, "(" ; Look for start of args
jrst morln2
cain ch, "<"
jrst outtlf
caie ch,";"
jrst morln1
jrst outtlf
morln2: movei s, 1 ; Init paren level
morln3: ildb ch, bp ; Get character
cain ch, 12 ; If eol,
jrst outtlf ; Write whole line
cain ch, "(" ; Keep track of paren level
aoja s, morln3
cain ch, ")" ; And look for matching close
sojle s, outtag
jrst morln3
morln6: call ratom
strmat PRECISION,morln5
ret
morln7: call ratom
jrst morln5
morln8: call ratom
strmat DATA,morln1
ret
; BASIC subroutine
b20lin: call ratom
b20ln0: call ratom
strmat DEF,b20ln1
strmat DEF*,b20ln1
strmat SUB,b20ln1
ret
b20ln1: 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 b20ln1
b20ln2: movei s, 1 ; Init paren level
b20ln3: ildb ch, bp ; Get character
cain ch, 12 ; If eol,
jrst outtlf ; Write whole line
cain ch, "(" ; Keep track of paren level
aoja s, b20ln3
cain ch, ")" ; And look for matching close
sojle s, outtag
jrst b20ln3
; 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
}
;
;(DEFTYPE (:MUTABLE DATUM) (:SPECIALIZES FUNCTION) :BUILTIN)
;(DEFUN FOO ()
;Find space or tab ending this atom.
mclln0: ildb ch, bp
caie ch, " "
cain ch, 11 ; Tab
jrst mclln1
cain ch, 12 ; No tag here if not one on this line.
ret
jrst mclln0
;Now find to end of this atom or list. Compensate for "", ||, and /.
;First, find beginning of this s-exp.
mclln1: ildb ch, bp
cain ch, 12
ret ; DEFUN hazy, try again later?
caie ch, " " ; Flush leading whitespace.
cain ch, 11 ; Tab
jrst mclln1
cain ch,"(" ; Special handler for allowing "(DEFUN (FOO BAR) ..)"
jrst mcllno
mclln3: caie ch, " " ; Find space, tab, or cr ending atom.
cain ch, 11 ; Tab
jrst outtag
cain ch, 12
jrst outtlf
caie ch, "(" ; ??? How do you get these?
cain ch, ")"
jrst outtag
caie ch, 42 ; Double quote or vbar: tag ends at its end.
cain ch, "|"
jrst [call mclvbr
jrst outtag]
cain ch, "/" ; Slash covers one character
ildb ch, bp
ildb ch, bp
jrst mclln3
;Here for vertical bar or double-quote seen in function being defined.
;Leaves bp pointing to closing delimiter.
mclvbr: push p, ch
mclvb1: ildb ch, bp
cain ch, 12 ; Abort at EOL inside vbars.
jrst mclvb2 ; (Tags format can't handle it.)
came ch, (p) ; Same delimiter?
jrst mclvb1
mclvb2: sub p, [1,,1] ; Throw away character.
ret
;Come here if we find a "(" where the start of the function name is supposed to be.
mcllno: movei u, 0 ; First paren seen.
;Here for recursive lists.
mcllnc: aoj u, ; Increment paren count.
;Here for plain get-next-character.
mclno1: ildb ch, bp
cain ch, 12
jrst outtlf ; OUTTLF if end of line within list??
cain ch, "(" ; Handle recursive lists.
jrst mcllnc
cain ch, ")" ; Scan to matching ")", but stop at end of line
jrst [sojle u, outtag ;When paren count gets to 0, that's it.
jrst mclno1] ;If not 0, gobble more chars.
caie ch, 42 ;Quote or vbar needs processing.
cain ch, "|"
jrst [call mclvbr
jrst mclno1]
cain ch, "/"
ildb ch, bp ; Slash makes following char not special.
cain ch, 12 ; Check again for EOL, since / doesn't matter.
jrst outtlf ; (TAGS format can't handle it.)
jrst mclno1
; 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 1000, parpdl] ; [PJG] 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
; 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: sub p, [1,,1] ; Flush callers return
ret ; And return to callers caller
; Local modes:
; Mode: FAIL
; Comment col:40
; Comment start:;
; End:
end go