Artifact 5f1506948cd99f9b7f19b77d4a478ac3cd12e2ef9ab9b796524d974d3a0dc4d8:


;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


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]