github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-15 20:36:13 +00:00
Code Issues Releases Wiki Activity

Builds all LISP; * FASL files that are on autoload properties when

Browse Source 
the lisp interpreter is first booted.

Redumps lisp compiler with updated FASL files built from source.
This commit is contained in:
Eric Swenson
2018-10-01 12:25:58 -07:00
parent 8f3e7b507c
commit cc8e6c1964
33 changed files with 16469 additions and 29 deletions
Download Patch File Download Diff File Expand all files Collapse all files

254
src/comlap/ledit.21 Executable file
View File

@@ -0,0 +1,254 @@
(comment LISP-TECO EDITOR INTERFACE) ; -*-LISP-*-
(declare (special ledit-jname ;atomic name of emacs job
ledit-loadfile ;namestring of binary file for editor
ledit-library ;namestring of teco macro library
ledit-tags ;namestring of tags file
ledit-tags-find-file ;0 or 1 controls setting of qreg in
; teco whether to use Find File
ledit-deletef ;switch, if T delete file from teco
; after reading
ledit-pre-teco-func ;called with list of arguments given
; to ledit
ledit-post-teco-func ;called with namestring of file
; returned from teco
ledit-pre-eval-func ;called with form to be eval'ed,
; returns form to be eval'ed instead
ledit-completed-func ;called after reading in is complete
ledit-eof ;gensym once to save time
ledit-jcl ;pre-exploded strings to save time
ledit-valret ;
ledit-proceed ;
ledit-jname-altj ;
ledit-lisp-jname ;
ledit-find-tag ;
ledit-find-file ;
ledit-lisp-mode ;
defun ;system variable
tty-return)) ;system variable
;; autoload properties for FLOAD stuff that used to be part of LEDIT
(defprop fload ((liblsp) fload fasl) autoload)
(defprop cload ((liblsp) fload fasl) autoload)
(defprop ledit-olderp ((liblsp) fload fasl) autoload))
(defprop ledit-agelist ((liblsp) fload fasl) autoload))
;; default values for global variables
(mapc
'(lambda (x y) (or (boundp x) (set x y)))
'(ledit-jname ledit-loadfile ledit-library ledit-tags ledit-tags-find-file
ledit-deletef ledit-pre-teco-func ledit-post-teco-func ledit-pre-eval-func
ledit-completed-func)
'(LEDIT |SYS2;TS EMACS| |EMACS;LEDIT| () 1
() () () () ())
)
(mapc '(lambda (x y) (set x (exploden y)))
'(ledit-jcl ledit-find-tag
ledit-find-file ledit-lisp-jname ledit-lisp-mode )
'(|:JCL | |WMM& LEDIT FIND TAG| |WMMFIND FILE|
|W:ILEDIT LISP JNAME| |WF~MODELISP"N1MMLISP MODEW'|)
)
(setq ledit-eof (gensym) ledit-jname-altj () ledit-valret () )
(setq ledit-proceed (exploden '|
/
..UPI0// /
:IF E Q&<%PIBRK+%PIVAL>/
(:ddtsym tygtyp///
:if n q&10000/
(: Teco Improperly Exited, Use ^Z (NOT CALL!)/
)/
:else/
(: Teco Improperly Exited, Use ^X^C (NOT ^Z !)/
)/
:SLEEP 30./
P/
:INPOP/
)/
2// /
Q+8//-1 /
.-1G|))
(defun LEDIT fexpr (spec)
;; if given one arg, is tag to be searched for (using FIND FILE) if more
;; than one arg, taken as file name to find (may be newio or oldio form)
(let ((newjob (cond ((not (job-exists-p (status uname) ledit-jname))
(setq ledit-jname-altj nil)
(setq ledit-valret nil)
(mapcan 'exploden (list '/
'|L| ledit-loadfile '/
'|G|)))))
(firstcall)
(atomvalret))
(and ledit-pre-teco-func (funcall ledit-pre-teco-func spec))
(or ledit-jname-altj ;memoize for fast calls later
(setq ledit-jname-altj (mapcan 'exploden (list '/
ledit-jname '|J|))
firstcall t))
(cond ((and ledit-valret (null spec)) ;go to teco in common case
(valret ledit-valret))
('t
(setq
atomvalret
(nconc
(list 23.) ;ctl-W
(append ledit-jcl () ) ;set own jcl line to ()
(append ledit-jname-altj () ) ;$J to ledit job
(append ledit-jcl () ) ;set jcl line for teco
(and newjob ;for new job only
(mapcan 'exploden
(list '|F~EDITOR TYPELEDIT/"NMMLOAD LIBRARY|
ledit-library '|'|)))
(and firstcall ;for first call only
(append ledit-lisp-mode () ))
(and firstcall ledit-tags ;for first call only
(mapcan 'exploden
(list ledit-tags-find-file
'|MMVISIT TAG TABLE| ledit-tags '/)))
(nconc (append ledit-lisp-jname () ) ;tell teco
(exploden (status jname)) ;lisp's jname
(list 27.)) ; altmode
(cond ((= (length spec) 1) ;tag
(nconc (append ledit-find-tag () )
(exploden (car spec))
(list 27.)))
((> (length spec) 1) ;file name
(nconc (append ledit-find-file () )
(exploden (namestring
(mergef spec defaultf)))
(list 27.)
(append ledit-lisp-mode () ))))
(or newjob ledit-proceed))) ;start new job
; or proceed old one
(setq atomvalret (maknam atomvalret))
(and (not firstcall) (not newjob) (null spec)
(setq ledit-valret
atomvalret)) ;memoize common simple case
(valret atomvalret))) ;go to teco
'*))
(defun LEDIT-TTY-RETURN (unused)
;; this function called by tty-return interrupt to read code back
;; from Teco
;; check JCL to see if it starts with LEDIT-JNAME
;; if so, rest of JCL is filename to be read in
;; note: need to strip off trailing <cr> on jcl
(declare (fixnum i))
(let ((jcl (status jcl)))
(cond ((and jcl
(setq jcl
(errset
(readlist (nreverse (cdr (nreverse jcl)))) nil))
(not (atom (setq jcl (car jcl))))
(eq (car jcl) ledit-jname))
(valret '|:JCL/
P|) ;clear jcl
(cursorpos 'c)
(nointerrupt nil)
(and ledit-post-teco-func
(funcall ledit-post-teco-func (cadr jcl)))
(cond ((cadr jcl) ;if non-null then read in file
;; read in zapped forms
(let ((file (open (cadr jcl) 'in))
(defun nil)) ;disable expr-hash
(princ '|;Reading from |)(prin1 ledit-jname)
;; Read-Eval-Print loop
(do ((form (cond (read (funcall read file ledit-eof))
(t (read file ledit-eof)))
(cond (read (funcall read file ledit-eof))
(t (read file ledit-eof)))))
((eq form ledit-eof) (close file)
(and ledit-deletef
(deletef file)))
(and ledit-pre-eval-func
(setq form (funcall ledit-pre-eval-func form)))
;; check if uuolinks might need to be snapped
(let ((p (memq (car (getl (cadr form)
'(expr subr fexpr
fsubr lsubr)))
'(subr fsubr lsubr))))
(print (eval form))
(cond ((and p
(memq (car (getl (cadr form)
'(expr subr fexpr
fsubr lsubr)))
'(expr fexpr)))
(sstatus uuolinks)
(princ '| ; sstatus uuolinks|))))))))
(and ledit-completed-func (funcall ledit-completed-func))
(terpri)
(princ '|;Edit Completed|)
(terpri)))))
(defun LEDIT-TTYINT (fileobj char)
;; intended to be put on control character, e.g.
;; (sstatus ttyint 5 'ledit-ttyint)
(nointerrupt nil)
(and (= (tyipeek nil fileobj) char)
(tyi fileobj)) ;gobble up control char
(apply 'ledit
(cond ((= (boole 1 127. ;note masking for 7 bit
(tyipeek nil fileobj)) 32.)
(tyi fileobj) ;gobble space
;; if space typed then just (ledit)
nil)
(t (let ((s (cond (read (funcall read fileobj))
(t (read fileobj)))))
(cond ((atom s)
(tyi fileobj)
(list s)) ;atom is taken as tag
(t s))))))) ;list is filename
;;Lap courtesy of GLS.
(declare (setq ibase 8.))
(LAP JOB-EXISTS-P SUBR)
(ARGS JOB-EXISTS-P (NIL . 2)) ;ARGS ARE UNAME AND JNAME, AS SYMBOLS
(PUSH P B)
(SKIPN 0 A) ;NULL UNAME => DEFAULT TO OWN UNAME
(TDZA TT TT) ;ZERO UNAME TELLS ITS TO DEFAULT THIS WAY
(PUSHJ P SIXMAK) ;CONVERT UNAME TO SIXBIT
(PUSH FXP TT)
(POP P A)
(PUSHJ P SIXMAK) ;CONVERT JNAME TO SIXBIT
(POP FXP T) ;UNAME IN T, JNAME IN TT
(MOVEI A '())
(*CALL 0 JEP43) ;SEE IF JOB EXISTS
(POPJ P) ;NO - RETURN NIL
(*CLOSE 0) ;YES - CLOSE THE CHANNEL
(MOVEI A 'T) ; AND RETURN T
(POPJ P)
JEP43 (SETZ)
(SIXBIT OPEN)
(0 0 16 5000) ;CONTROL BITS: IMAGE BLOCK INPUT/INSIST
; JOB EXISTS
(0 0 0 1000) ;CHANNEL # - 0 IS SAFE IN BOTH OLDIO AND NEWIO
(0 0 (% SIXBIT USR)) ;DEVICE NAME (USR)
(0 0 T) ;UNAME
(0 0 TT 400000) ;JNAME
()
;set control-E unless already defined
(or (status ttyint 5) (sstatus ttyint 5 'ledit-ttyint))
(or tty-return (setq tty-return 'ledit-tty-return))

1262
src/l/allfil.132 Executable file
View File

File diff suppressed because it is too large Load Diff

467
src/l/bltarr.3 Executable file
View File

@@ -0,0 +1,467 @@
;;; BLTARR -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** BLTARRAY ********************************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
.SYMTAB 16001. ;1863.rd prime
TITLE ***** MACLISP ****** BLTARRAY ********************************
;; To assemble on one kind of Operating system, for use on another,
;; you should use the "T" command line switch in order to insert one
;; of the redefinitions:
;; D10==1
;; D20==1
;; ITS==1
;; SAIL==1
.FASL
IF1,[
IFNDEF TOPS10, TOPS10==0
IFNDEF TOPS20, TOPS20==0
IFNDEF TENEX, TENEX==0
IFNDEF CMU, CMU==0
IFN TOPS10\CMU, D10==1
IFN TOPS20\TENEX, D20==1
IFE .OSMIDAS-<SIXBIT \ITS\>,[
IFNDEF D20, D20==0
IFNDEF D10, D10==0
IFNDEF SAIL SAIL==0
IFNDEF ITS,[
IFE D10+D20+SAIL, ITS==1
.ELSE ITS==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
$FNAME .IFNM1
PRINTX \ \
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
IFE .OSMIDAS-<SIXBIT \DEC\>,[
IFNDEF ITS, ITS==0
IFNDEF D20, D20==0
IFNDEF SAIL SAIL==0
IFNDEF D10,[
IFE ITS+D20+SAIL, D10==1
.ELSE D10==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
IFE .OSMIDAS-<SIXBIT \TWENEX\>,[
IFNDEF ITS, ITS==0
IFNDEF D10, D10==0
IFNDEF SAIL SAIL==0
IFNDEF D20,[
IFE ITS+D10+SAIL, D20==1
.ELSE D20==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \TWENEX\>,
IFE .OSMIDAS-<SIXBIT \SAIL\>,[
IFNDEF ITS, ITS==0
IFNDEF D10, D10==0
IFNDEF D20, D20==0
IFNDEF SAIL,[
IFE ITS+D10+D20, SAIL==1
.ELSE SAIL==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \SAIL\>,
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
ZZX==<FOO>
REPEAT 6,[
IRPNC ZZX_-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)^_]
IFSN [Q][ ] PRINTX |Q|
TERMIN
ZZX==ZZX_6
]
TERMIN
IFN ITS+D10+D20+SAIL-1,[
INFORM [
ITS=]\ITS,[ D10=]\D10,[ D20=]\D20,[ SAIL=]\SAIL
.FATAL ITS, D10, D20, and SAIL switches are not consistent
] ;END OF IFN ITS+D10+D20+SAIL-1
D10==:TOPS10\CMU ;SWITCH FOR DEC-10-LIKE SYSTEMS
D20==:TOPS20\TENEX ;SWITCH FOR DEC-20-LIKE SYSTEMS
IFN D10,[
PRINTX \ASSEMBLING DEC-10 BLTARRAY
\
]
IFN D20,[
PRINTX \ASSEMBLING DEC-20 BLTARRAY
\
]
IFN ITS,[
PRINTX \ASSEMBLING ITS BLTARRAY
\
]
IFN SAIL, D10==1
$INSRT FASDFS
;;; MAKE SURE THE SYMBOLS WE WILL NEED ARE DEFINED.
;;; THEY MAY NOT BE IF ASSEMBLING FOR A DIFFERENT OPERATING SYSTEM
DEFINE FLUSHER DEF/
IRPS SYM,,[DEF]
EXPUNGE SYM
.ISTOP
TERMIN
TERMIN
DEFINE SYMFLS TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFE <.OSMIDAS-SIXBIT\OS\>,[
IFE TARGETSYS,[
PRINTX \FLUSHING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER FLUSHER
IFSN .BITS.,,[
PRINTX \FLUSHING OS BIT DEFINITIONS
\
EQUALS DEFSYM,FLUSHER
$INSRT .BITS.
EXPUNGE DEFSYM
] ;END OF IFSN .BITS.
] ;END OF IFE TARGETSYS
] ;END OF IFE <.OSMIDAS-SIXBIT\OS\>
TERMIN
DEFINE SYMDEF TARGETSYS,OS,.DEFS.,DEFFER,CHKSYM,.BITS.,CHKBIT
IFN TARGETSYS,[
IFN <.OSMIDAS-SIXBIT\OS\>,[
PRINTX \MAKING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER
IFSN .BITS.,,[
PRINTX \MAKING OS BIT DEFINITIONS
\
$INSRT .BITS.
] ;END OF IFSN .BITS.,,
] ;END OF IFN <.OSMIDAS-SIXBIT\OS\>
.ELSE,[
IFNDEF CHKSYM,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKSYM UNDEFINED; MAKING OS SYMBOL DEFINITIONS
\
$INSRT .DEFS.
DEFFER
] ;END OF IFNDEF CHKSYM
IFSN .BITS.,,[
IFNDEF CHKBIT,[
PRINTX \FUNNY - RUNNING ON OS, BUT CHKBIT UNDEFINED; MAKING OS BIT DEFINITIONS
\
$INSRT .BITS.
] ;END OF IFNDEF CHKBIT
] ;END OF IFSN .BITS.,,
] ;END OF .ELSE
] ;END OF IFN TARGETSYS
TERMIN
IRP HACK,,[SYMFLS,SYMDEF]
HACK ITS,ITS,ITSDFS,.ITSDF,.IOT,ITSBTS,%PIC.Z
HACK TOPS10,DEC,DECDFS,.DECDF,LOOKUP,DECBTS,.GTSTS
HACK TOPS20,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
HACK TENEX,TENEX,TNXDFS,.TNXDF,JSYS,TWXBTS,GJ%FOU
HACK SAIL,SAIL,SAIDFS,.DECDF,SPCWAR,DECBTS,.GTSTS
TERMIN
] ;END OF IF1
VERPRT BLTARRAY
.ENTRY BLTARRAY SUBR 3 ;2 ARGS
EXCH A,B ;GRUMBLE! CALLED BY FILLARRAY
SOVE B C AR1 AR2A
PUSHJ P,AREGET
MOVEI AR1,(A)
HRRZ A,-3(P)
BLTAR1: PUSHJ P,AREGET
MOVEI AR2A,(A)
MOVE T,ASAR(AR1)
MOVE TT,ASAR(AR2A)
;; NEXT FEW LINES SHOULD BE CONDITIONAL ON HAVING JOBQIO
TLNE T,AS.JOB
JRST BLTALS
TLNE TT,AS.JOB
JRST BLTALZ
TLNE T,AS.FIL
JRST BLTI1
TLNE TT,AS.FIL
JRST BLTO1
LOCKI
PUSHJ P,.REA3
JRST BLTALZ ;ARRAY TYPES DON'T MATCH - LOSE LOSE
BLTXIT: RSTR AR2A AR1 C
UNLOCKI
JRST POPAJ
BLTALZ: UNLOCKI
MOVEI A,(AR2A)
WTA [BAD TARGET ARRAY TYPE - BLTARRAY!]
MOVEI AR2A,(A)
JRST BLTAR1
BLTALS: UNLOCKI
MOVEI A,(AR1)
WTA [BAD SOURCE ARRAY TYPE - BLTARRAY!]
MOVEI AR1,(A)
JRST BLTAR1
;FILL OUTPUT FILE IN AR2A FROM ARRAY IN AR1.
BLTO1: TLNE T,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD
JRST BLTALS
EXCH AR1,AR2A
PUSHJ P,XOFLOK ;MAKE SURE TARGET ARRAY IS BINARY OUTPUT
IFN ITS,[
PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE D,TT ;MOVE INTO D
HRRZ T,TTSAR(AR2A)
HRLI T,444400 ;SET UP BYTE POINTER (BYTE = 36. BITS)
MOVE TT,TTSAR(AR1)
ADDM D,F.FPOS(TT)
.CALL BSIOT ;TRANSFER DATA TO FILE
.LOSE 1400
JSP D,BFORC6 ;UPDATE FILE OBJECT VARIABLES
] ;END OF IFN ITS
IFN D20,[
PUSHJ P,IFORCE ;FORCE OUT CURRENT BUFFER, IF ANY
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
HRRZ 2,TTSAR(AR2A)
HRLI 2,444400 ;SET UP BYTE POINTER (BYTE = 36. BITS)
MOVN 3,TT ;NEGATIVE OF NUMBER OF BYTES
MOVE D,TT
MOVE TT,TTSAR(AR1)
HRRZ 1,F.JFN(TT) ;GET JFN FOR FILE
ADDM D,F.FPOS(TT)
SOUT ;TRANSFER DATA TO FILE
SETZB 2,3 ;FLUSH CRUD FROM AC'S
JSP D,BFORC6 ;UPDATE FILE OBJECT VARIABLES
] ;END OF IFN D20
IFN D10,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR I/O FILE
LSH B,27
TLO B,(OUT 0,) ;CONSTRUCT AN OUT INSTRUCTION
MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK
BLTO3: MOVE D,1(A) ;GET BYTE POINTER INTO BUFFER
ADDI D,1 ;ADDRESS OF FIRST FREE WORD IN BUFFER
HRLI D,(T) ;ADDRESS OF NEXT DATA WORD TO TRANSFER
SKIPN R,2(A) ;GET COUNT OF FREE BUFFER WORDS IN R
JRST BLTO4 ;OOPS, NONE - GO OUTPUT THIS BUFFER
CAILE R,(TT) ;IF REST OF DATA FITS IN BUFFER,
MOVEI R,(TT) ; TRANSFER NO MORE THAN NECESSARY
SUB TT,2(A) ;SUBTRACT FREE WORDS IN BUFFER FROM COUNT OF REMAINING DATA
MOVNS R
ADDM R,2(A) ;ADJUST BUFFER FREE COUNT FOR WORDS TRANSFERRED
MOVNS R
ADDB R,1(A) ;ADJUST BYTE POINTER, GET FINAL ADDRESS
BLT D,(R)
JUMPL TT,BLTXIT ;DIDN'T COMPLETELY FILL THIS LAST BUFFER, SO EXIT
BLTO4: XCT B ;OUTPUT THIS BUFFER
CAIA
HALT ;? THE OUTPUT LOST SOMEHOW
MOVE D,FB.BFL(F)
ADDM D,F.FPOS(F) ;UPDATE FILEPOS
JUMPG TT,BLTO3 ;GO AROUND AGAIN IF MORE DATA LEFT
] ;END OF IFN D10
JRST BLTXIT
IFN ITS+D20,[
BFORC6: MOVE T,FB.BFL(TT) ;ROUTINE TO INITIALIZE BYTE POINTER AND COUNT
MOVEM T,FB.CNT(TT)
MOVE T,FB.IBP(TT)
MOVEM T,FB.BP(TT)
JRST (D)
];END IFN ITS+D20
;FILL ARRAY IN AR2A FROM FILE IN AR1.
BLTI1: TLNE TT,AS.FIL+AS.RDT+AS.OBA+AS.GCP ;FILES, READTABLES, OBARRAYS, S-EXPS BAD
JRST BLTALZ
PUSHJ P,XIFLOK ;MAKE SURE SOURCE IS AN INPUT BINARY FILE
IFN ITS+D20,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
SKIPN R,FB.CNT(F) ;GET NUMBER OF DATA WORDS IN INPUT BUFFER
JRST BLTI4 ;NONE, GO DO DIRECT INPUT
CAILE R,(TT) ;TRANSFER NO MORE WORDS THAN
MOVEI R,(TT) ; THE TARGET ARRAY WILL HOLD
SUBI TT,(R) ;ADJUST COUNT FOR NUMBER OF WORDS TRANSFERRED
MOVN D,R
ADDM D,FB.CNT(F) ;ADJUST BYTE COUNT IN FILE OBJECT
IBP FB.BP(F) ;BYTE POINTER TO POINT TO FIRST BYTE WE WANT
MOVE D,FB.BP(F)
HRLI D,(D) ;ADDRESS OF FIRST WORD OF INPUT DATA
HRRI D,(T)
ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY
SUBI R,1 ;FOR CORRECT UPDATING, R IS 1 TOO BIG
ADDM R,FB.BP(F) ;UPDATE FILE BYTE POINTER
BLT D,-1(T) ;TRANSFER DATA
JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA
MOVE D,FB.BVC(F)
ADDM D,F.FPOS(F)
SETZM FB.BVC(F)
BLTI4:
IFN ITS,[
MOVE R,TT
MOVE D,TT ;GET COUNT OF BYTES
MOVE TT,F
HRLI T,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS)
.CALL BSIOT ;INPUT MORE DATA
.LOSE 1400
SUB R,D
ADDM R,F.FPOS(TT) ;UPDATE THE FILE POSITION
JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA
] ;END OF IFN ITS
IFN D20,[
HRRZ 1,F.JFN(F) ;GET JFN FOR FILE
MOVEI 2,(T)
HRLI 2,444400 ;MAKE BYTE POINTER (BYTE = 36. BITS)
MOVN 3,TT
SIN ;INPUT MORE DATA
ADD TT,3 ;NOT ADDI!!!
ADDM TT,F.FPOS(F) ;UPDATE THE FILE POSITION
MOVE D,3
SETZB 2,3 ;FLUSH JUNK FROM AC'S
JUMPE D,BLTXIT ;JUMP IF WE GOT ALL THE DATA
] ;END OF IFN D20
] ;END OF IFN ITS+D20
IFN D10,[
MOVEI A,(AR2A)
JSP T,ARYSIZ ;GET NUMBER OF DATA WORDS IN TT
MOVE T,TTSAR(AR2A)
MOVE F,TTSAR(AR1)
MOVE B,F.CHAN(F) ;GET CHANNEL NUMBER FOR FILE
LSH B,27
TLO B,(IN 0,) ;CONSTRUCT AN IN INSTRUCTION
MOVE A,FB.HED(F) ;GET ADDRESS OF BUFFER HEADER BLOCK
BLTI3: SKIPN R,2(A) ;CHECK NUMBER OF WORDS IN THIS BUFFER
JRST BLTI5 ;NONE - GO READ SOME MORE
CAILE R,(TT) ;DON'T TRANSFER MORE WORDS
MOVEI R,(TT) ; THAN THE TARGET ARRAY NEEDS
SUBI TT,(R) ;ADJUST COUNT OF WORDS NEEDED
MOVN D,R
ADDM D,2(A) ;ADJUST COUNT IN BUFFER HEADER
MOVE D,1(A) ;GET BYTE POINTER TO INPUT BUFFER
HRLI D,1(D)
HRRI D,(T) ;FORM BLT POINTER
ADDI T,(R) ;UPDATE POINTER INTO TARGET ARRAY
ADDM R,1(A) ;UPDATE INPUT BUFFER BYTE POINTER
BLT D,-1(T) ;TRANSFER DATA TO TARGET ARRAY
JUMPLE TT,BLTXIT ;EXIT IF WE GOT ENOUGH DATA
BLTI5: XCT B ;GET MORE DATA
JRST BLTI6 ;JUMP IF AN ERROR OCCURRED
MOVE D,FB.BFL(F)
ADDM D,F.FPOS(F) ;UPDATE FILE POSITION
JRST BLTI3
BLTI6: MOVE D,B ;CONSTRUCT A TEST FOR END OF FILE
XOR D,[<STATO 0,IO.EOF>#<IN 0,>]
XCT D
HALT ;LOSE TOTALLY IF NOT END OF FILE
] ;END OF IFN D10
HRRZ C,FI.EOF(TT) ;GET EOF FUNCTION FOR FILE
UNLOCKI
JUMPE C,BLTI8
MOVEI A,(AR1)
JCALLF 1,(C) ;CALL USER EOF FUNCTION
BLTI8: MOVEI A,(AR2A)
CALL 1,.FUNCTION NCONS
MOVEI B,(AR1)
CALL 2,.FUNCTION XCONS
MOVEI B,.ATOM FILLARRAY
CALL 2,.FUNCTION XCONS
IOL [EOF - FILLARRAY!] ;ELSE GIVE IO-LOSSAGE ERROR
IFN ITS,[
BSIOT: SETZ
SIXBIT \SIOT\ ;STRING I/O TRANSFER
,,F.CHAN(TT) ;CHANNEL #
,,T ;BYTE POINTER
400000,,D ;BYTE COUNT
]
FASEND

707
src/l/getmid.18 Executable file
View File

@@ -0,0 +1,707 @@
;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** MIDAS OP-DECODER (GETMIDASOP) ***********
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
TITLE ***** MACLISP ****** MIDAS OP-DECODER (GETMIDASOP) ***********
;; To assemble on one kind of Operating system, for use on another,
;; you should use the "T" command line switch in order to insert one
;; of the redefinitions:
;; D10==1
;; D20==1
;; ITS==1
;; SAIL==1
.FASL
IF1,[
IFNDEF TOPS10, TOPS10==0
IFNDEF TOPS20, TOPS20==0
IFNDEF TENEX, TENEX==0
IFNDEF CMU, CMU==0
IFN TOPS10\CMU, D10==1
IFN TOPS20\TENEX, D20==1
IFE .OSMIDAS-<SIXBIT \ITS\>,[
IFNDEF D10, D10==0
IFNDEF D20, D20==0
IFNDEF SAIL SAIL==0
IFNDEF ITS,[
IFE D10+D20+SAIL, ITS==1
.ELSE ITS==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
$FNAME .IFNM1
PRINTX \ \
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
IFE .OSMIDAS-<SIXBIT \DEC\>,[
IFNDEF ITS, ITS==0
IFNDEF D20, D20==0
IFNDEF SAIL SAIL==0
IFNDEF D10,[
IFE ITS+D20+SAIL, D10==1
.ELSE D10==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
IFE .OSMIDAS-<SIXBIT \TWENEX\>,[
IFNDEF ITS, ITS==0
IFNDEF D10, D10==0
IFNDEF SAIL SAIL==0
IFNDEF D20,[
IFE ITS+D10+SAIL, D20==1
.ELSE D20==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \TWENEX\>,
IFE .OSMIDAS-<SIXBIT \SAIL\>,[
IFNDEF ITS, ITS==0
IFNDEF D10, D10==0
IFNDEF D20, D20==0
IFNDEF SAIL,[
IFE ITS+D10+D20, SAIL==1
.ELSE SAIL==0
]
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \SAIL\>,
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
ZZX==<FOO>
REPEAT 6,[
IRPNC ZZX_-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)^_]
IFSN [Q][ ] PRINTX |Q|
TERMIN
ZZX==ZZX_6
]
TERMIN
IFN ITS+D10+D20+SAIL-1,[
INFORM [
ITS=]\ITS,[ D10=]\D10,[ D20=]\D20,[ SAIL=]\SAIL
.FATAL ITS, D10, D20, and SAIL switches are not consistent
] ;END OF IFN ITS+D10+D20+SAIL-1
D10==:TOPS10\CMU ;SWITCH FOR DEC-10-LIKE SYSTEMS
D20==:TOPS20\TENEX ;SWITCH FOR DEC-20-LIKE SYSTEMS
IFN D10,[
PRINTX \ASSEMBLING OP-DECODER FOR DEC-10 STYLE SYSTEM
\
]
IFN D20,[
PRINTX \ASSEMBLING OP-DECODER FOR DEC-20 STYLE SYSTEM
\
]
IFN SAIL,[
PRINTX \ASSEMBLING OP-DECODER FOR SAIL SYSTEM
\
]
IFN ITS,[
PRINTX \ASSEMBLING OP-DECODER FOR ITS SYSTEM
\
]
IFN SAIL, D10==1
$INSRT FASDFS
] ;END OF IF1
VERPRT GETMIDASOP
.ENTRY GETMIDASOP SUBR 2 ;THIS SAYS "1 ARG"
GETMIDASOP:
PUSH FXP,[0] ;SIXBIT IN R, SQUOZE ON 0(FXP)
PUSH P,A ;THIS PUSH PURELY FOR GC PROTECTION DURING SQOZ|
HRLZS A ;A PSEUDO NCONS ON THE ARG
PUSH P,A
MOVEI A,(P)
NCALL 1, .FUNCTION SQOZ|
MOVEM TT,(FXP)
SUB P,[2,,2]
SETZB A,D ;NOTE THAT A HAS NIL UNTIL FURTHER NOTICE
LSHC D,6 ;D GETS FIRST CHARACTER
IT$ CAIN D,'. ;IS FIRST CHAR OF SYMBOL A .?
IT$ JRST GTMOP1 ;IF NOT, TRY SEARCHING MOBY OPCODE TABLE FOR IT
SETZB TT,AR2A ;TT HOLDS BINARY OPCODE, AR2A HOLDS TABLE INDEX
CAIL D,'L ;IF IT'S L OR HIGHER, LET'S SAVE TIME
MOVEI AR2A,OPTBLL-OPTABL ; BY STARTING HALFWAY DOWN THE FIRST LIST
GTMOP2: LDB T,[271400,,OPTABL(AR2A)] ;GET CHAR(S) FROM TABLE ENTRY
CAIN D,(T) ;COMPARE TO CHAR(S) FROM SIXBIT SYMBOL
JRST GTMOP3 ;A MATCH!
SKIPL OPTABL(AR2A) ;SKIP IF LAST ENTRY IN TABLE
AOJA AR2A,GTMOP2 ;ELSE TRY NEXT ENTRY
GMXIT: SUB FXP,[1,,1]
POPJ P, ;LOSE - A STILL HAS NIL
GTMOP3: ADD TT,OPTABL(AR2A) ;ADD OPCODE MODIFIER TO RUNNING SUM (EXTRA BITS DON'T HURT)
LDB T,[220400,,OPTABL(AR2A)] ;HOW MANY CHARS SHALL WE CHECK NEXT?
JUMPE T,GTMOP4 ;NONE - END OF THE TREE BRANCH
SETZ D,
LSHC D,(T) ;1 OR 2 CHARS - PUT THEM IN D
LDB AR2A,[111100,,OPTABL(AR2A)] ;PUT POINTER TO NEXT LIST IN AR2A
JRST GTMOP2 ;CONTINUE MOBY SEARCH
GTMOP4: JUMPN R,GMXIT ;REST OF SIXBIT SHOULD BE ZERO - ELSE LOSE (A STILL HAS NIL)
LSH TT,33 ;SHIFT 9 BIT OPCODE TO TOP OF WORD
GMXT1: JSP T,FIX1A" ;RETURN AS NUMERIC VALUE (HOORAY!)
JRST GMXIT
IFN ITS,[
GTMOP1: .EVAL TT, ;TRY GETTING SYM VAL FROM ITS SYSTEM
JRST GMXIT ;LOSE - A HAS NIL
JRST GMXT1 ;WIN - VALUE IS IN TT
] ;END OF IFN ITS
;;; THE FOLLOWING TABLE IS FOR USE BY THE GETMIDASOP ROUTINE IN DECODING PDP-10
;;; OPCODES. IT CONTAINS REPRESENTATIONS FOR ALL STANDARD PDP-10 OPCODE
;;; SYMBOLS, AS WELL AS THE LISP UUO'S LERR, LER2, LER3, LER4, ERINT, AND STRT.
;;; THE TABLE IS IN THE FORM OF A SET OF LISTS WHICH ARE LINKED TO ONE ANOTHER
;;; TO FORM A TREE. EACH LIST ENTRY IS ONE WORD IN THE FOLLOWING FORMAT:
;;; BIT 4.9 IF 1, INDICATES THE LAST ENTRY OF THE LIST
;;; BITS 4.3-4.8 FIRST OF TWO SIXBIT CHARS TO COMPARE
;;; BITS 3.6-4.2 SECOND OR ONLY SIXBIT CHAR TO COMPARE
;;; BIT 3.5 UNUSED
;;; BITS 3.1-3.4 6*<NUMBER OF CHARS IN ENTRIES IN NEXT LIST>
;;; ZERO IF THERE IS NO NEXT LIST - IMPLIES REST OF
;;; SYMBOL MUST BE BLANK
;;; BITS 2.1-2.9 OFFSET FROM BEGINNING OF TABLE POINTING TO NEXT
;;; LIST TO USE TO CONTINUE THE COMPARISON
;;; BITS 1.1-1.9 VALUE TO BE ADDED TO A RUNNING SUM TO PRODUCE
;;; THE BINARY OPCODE
;;; THE TREE IS TRACED BY BEGINNING WITH THE LIST STARTING AT LOCATION
;;; OPTABL. AT EACH STEP ONE THEN SCANS THE CURRENT LIST, COMPARING THE
;;; NEXT ONE OR TWO CHARACTERS OF THE SYMBOL TO THOSE IN THE TABLE.
;;; IF NO MATCH IS FOUND, THE SYMBOL IS NOT IN THE TBALE. IF A MATCH IS
;;; FOUND, BITS 1.1-1.9 ARE ADDED TO A RUNNING SUM, BITS 2.1-2.9 POINT
;;; TO THE NEXT LIST TO SCAN, AND BITS 3.1-3.4 INDICATE HOW MANY CHARACTERS
;;; OF THE SYMBOL TO COMPARE TO THAT TABLE. IF BITS 3.1-3.4 ARE ZERO,
;;; THEN IF THERE REMAIN NON-BLANK CHARACTERS IN THE SYMBOL, THE SYMBOL
;;; IS NOT IN THE TABLE; IF THE REST OF THE SYMBOL IS BLANK, THEN THE
;;; RUNNING SUM IS THE FINAL 9 BIT BINARY OPCODE.
DEFINE OP CHARS,OFFSET,OPVAL,LASTP ;CREATE LIST ENTRY FOR OPCODE TABLE
ZZZ==0
IRPC X,,[CHARS]
IFSE X,-, ZZZ==ZZZ_6
IFSN X,-, ZZZ==ZZZ_6+'X
TERMIN
IFSN LASTP,, ZZZ==ZZZ+11_14
<OFFSET>+<OPVAL>+ZZZ_27
TERMIN
DEFINE OPTB NAME,N ;CREATE SYMBOL TO USE AS SECOND ARG TO OP MACRO
IRPS Q,,[NAME]
Q==<.-OPTABL>_11(6*N)
TERMIN
TERMIN
.XCREF OP OPTB
;;; FOR THE DECSYSTEM-10 VERSION, THE FOLLOWING UUO'S ARE
;;; DEFINED IN ADDITION TO LISP UUO'S AND PDP-10 OPCODES.
;;; WARNING! THE VALUE SUPPLIED FOR THE SYMBOL "CALL" IS
;;; THAT FOR THE LISP UUO, NOT FOR THE DECSYSTEM-10 UUO!
;;; CALLI 47 MTAPE 72 STATO 61
;;; CLOSE 70 OPEN 50 STATZ 63
;;; ENTER 77 OUT 57 TTCALL 51
;;; GETSTS 62 OUTBUF 65 UGETF 73
;;; IN 56 OUTPUT 67 USETI 74
;;; INBUF 64 RELEASE 71 USETO 75
;;; INPUT 66 RENAME 55
;;; LOOKUP 76 SETSTS 60
;;; FOR THE SAIL VERSION THE FOLLOWING OPCODES ARE DEFINED
;;; CLKINT 717 DPYCLR 701 MAIL 710
;;; PGIOT 715 PPIOT 702 PTYUUO 711
;;; TTYUUO 051 UPGIOT 703 UPGMVE 713
;;; UPGMVM 714
OPTABL: OP A,OP.A ;INITIAL LETTERS FOR
OP B,OP.B ; ALL INSTRUCTIONS
OP C,OP.C
OP D,OP.D
OP E,OP.E
OP F,OP.F
10$ OP G,OP.G
OP H,OP.H
OP I,OP.I
OP J,OP.J,,*
OPTBLL: OP L,OP.L ;THIS LIST IS IN TWO
OP M,OP.M ; HALVES FOR SPEED
OP N,OP.N
OP O,OP.O ; IN SEARCHING
OP P,OP.P
OP R,OP.R
OP S,OP.S
OP T,OP.T
OP U,OP.U
OP X,OP.X,,*
OPTB OP.A:,2
OP DD,OP.IMB,270 ;ADD--
OP ND,OP.AND,404 ;AND--
OP OB,OP.AOB,252 ;AOBJP, AOBJN
OP OJ,OP.CND,340 ;AOJ--
OP OS,OP.CND,350 ;AOS--
OP SH,OP.SHF,240 ;ASH, ASHC
OP CA,OP.%LL,002 ;CALL, CALLF
OP JC,OP.AJC,003,* ;AJCALL
OPTB OP.B:,2
OP LT,,251,* ;BLT
OPTB OP.C:,2
OP AI,OP.CND,300 ;CAI--
OP AM,OP.CND,310 ;CAM--
SA$ OP HN,OP.STS,716 ;CHNSTS (SAIL)
10% OP IR,OP.CIR,243 ;CIRC (AI-ITS ONLY)
SA$ OP LK,OP.%NT,717 ;CLKINT (SAIL)
10$ OP LO,OP.%SE,070 ;CLOSE (D10 ONLY)
OP AL,OP.CAL,,* ;CALL, CALLF; CALLI
OPTB OP.D:,2
SA$ OP PY,OP.DPY,701 ;DPYCLR (SAIL)
OP IV,OP.IMB,234 ;DIV--
OP PB,,137 ;DPB
OP FN,,131,* ;DFN
OPTB OP.E:,2
OP QV,OP.IMB,444 ;EQV--
OP XC,OP.%%H,250 ;EXCH
10$ OP NT,OP.%ER,077 ;ENTER (D10 ONLY)
OP RI,OP.%NT,005,* ;ERINT
OPTB OP.F:,2
OP AD,OP.FLT,140 ;FAD--
OP SB,OP.FLT,150 ;FSB--
OP MP,OP.FLT,160 ;FMP--
OP DV,OP.FLT,170 ;FDV--
OP SC,,132,* ;FSC
IFN D10,[
OPTB OP.G:,2
OP ET,OP.STS,62,* ;GETSTS (D10 ONLY)
] ;END OF IFN D10
OPTB OP.H:,2
OP LL,OP.ZOE,500 ;HLL--
OP RL,OP.ZOE,504 ;HRL--
OP RR,OP.ZOE,540 ;HRR--
OP LR,OP.ZOE,544,* ;HLR--
OPTB OP.I:,2
OP OJ,OP.RS,012 ;IOJ---
OP OR,OP.IMB,434 ;IOR--
OP MU,OP.IMU,220 ;IMUL--
OP DI,OP.IDI,230 ;IDIV--
OP LD,OP.%%B,134 ;ILDB
OP DP,OP.%%B,136 ;IDPB
SA$ OP OP,OP.IOP,724 ;IOPDL,IOPOP,IOPUSH (SAIL ONLY)
10$ OP NB,OP.%UF,064 ;INBUF (D10 ONLY)
10$ OP NP,OP.%UT,066 ;INPUT (D10 ONLY)
10$ OP N-,,056 ;IN (D10 ONLY)
OP BP,,133,* ;IBP
OPTB OP.J:,2
OP UM,OP.JSK,320 ;JUMP--
OP RS,OP.%%T,254 ;JRST
OP SR,,264 ;JSR
OP SP,,265 ;JSP
OP CA,OP.N%J,015 ;JCALL, JCALLF
OP FC,OP.%%L,255 ;JFCL
OP SA,,266 ;JSA
OP RA,,267 ;JRA
20$ OP SY,OP.%%S,104 ;JSYS (TWENEX ONLY)
OP FF,OP.%%O,243,* ;JFFO
OPTB OP.L:,2
OP SH,OP.SHF,242 ;LSH, LSHC
OP DB,,135 ;LDB
10$ OP OO,OP.KUP,076 ;LOOKUP (D10 ONLY)
OP ER,OP.LER,,* ;LER--
OPTB OP.M:,2
SA$ OP AI,OP.MAI ;MAIL (SAIL)
OP OV,OP.MOV,200 ;MOV--
10$ OP TA,OP.%PE,072 ;MTAPE (D10 ONLY)
OP UL,OP.IMB,224,* ;MUL--
OPTB OP.N:,2
OP CA,OP.N%J,20 ;NCA---
OP JC,OP.NJC,21,* ;NJC---
OPTB OP.O:,2
10$ OP PE,OP.%%N,050 ;OPEN (D10 ONLY)
10$ OP UT,OP.OUT ;OUTPUT, OUTBUF (D10 ONLY)
OP RC,OP.ORC,,* ;ORC--
OPTB OP.P:,2
SA$ OP TY,OP.UUO,711 ;PTYUUO (SAIL)
SA$ OP PI,OP.OT,702 ;PPIOT (SAIL)
SA$ OP GI,OP.OT,715 ;PGIOT (SAIL)
OP US,OP.PUS,260 ;PUSHJ, PUSH
OP OP,OP.POP,262,* ;POP, POPJ
OPTB OP.R:,2
10$ OP EL,OP.REL,071 ;RELEAS (D10 ONLY)
10$ OP EN,OP.REN,055 ;RENAME (D10 ONLY)
OP OT,OP.SHF,241,* ;ROT, ROTC
OPTB OP.S:,2
OP KI,OP.JSK,330 ;SKIP--
OP UB,OP.IMB,274 ;SUB--
OP OJ,OP.CND,360 ;SOJ--
OP OS,OP.CND,370 ;SOS--
OP ET,OP.SET,400 ;SET--
OP ER,OP.SER,010 ;SERINT
10$ OP ET,OP.STS,60 ;SETSTS (D10 ONLY)
10$ OP TA,OP.STA ;STATO, STATZ (D10 ONLY)
OP TR,OP.%$T,007,* ;STRT
OPTB OP.T:,1
10$ OP T,OP.TT,051 ;TTYCAL (D10 ONLY)
OP R,OP.ZCO,600 ;TR--
OP L,OP.ZCO,601 ;TL--
OP D,OP.ZCO,610 ;TD--
OP S,OP.ZCO,611,* ;TS--
OPTB OP.U:,2
SA$ OP PG,OP.UPG ;UPG--- (SAIL)
10$ OP GE,OP.UGE ;UGETF (D10 ONLY)
10$ OP SE,OP.USE ;USETI, USETO (D10 ONLY)
OP FA,,130,* ;UFA
OPTB OP.X:,2
OP OR,OP.IMB,430 ;XOR--
OP CT,,256,* ;XCT
OPTB OP.AND:,1
OP C,OP.NDC,4 ;ANDC--
OPTB OP.IMB:,1 ;ADDRESSING MODES
OP -,,0 ; NORMAL
OP I,,1 ; IMMEDIATE
OP M,,2 ; MEMORY
OP B,,3,* ; BOTH
OPTB OP.AOB:,2
OP JP,,0 ;AOBJP
OP JN,,1,* ;AOBJN
OPTB OP.CND:,2 ;CONDITION MODIFIERS
OP L-,,1 ; LESS
OP LE,,3 ; LESS OR EQUAL
OP GE,,5 ; GREATER OR EQUAL
OP G-,,7 ; GREATER
OPTB OP.EAN:,2 ;CONDITIONS FOR TEST INSTRUCTIONS
OP --,,0 ; NEVER
OP E-,,2 ; EQUAL
OP A-,,4 ; ALWAYS
OP N-,,6,* ; NOT EQUAL
OPTB OP.SHF:,1 ;SHIFT MODIFIERS
OP -,,0 ; ASH, ROT, LSH
OPTB OP.CIR:,1
OP C,,4,* ; ASHC, ROTC, LSHC, CIRC
OPTB OP.CAL:,1
OP L,OP.CLX,014,* ;CALL, CALLF
OPTB OP.N%J:,2
OP LL,OP.CLY,,*
OPTB OP.CLX:,1
10$ OP I,,033 ;CALLI (D10 ONLY)
OPTB OP.CLY:,1
OP -,,0 ;CALL, JCALL, NCALL
OP F,,2,* ;CALLF, JCALLF, NCALLF
OPTB OP.NJC:,2
OP AL,OP.NJ1,,*
OPTB OP.NJ1:,1
OP F,,2 ;NJCALF
OPTB OP.%%L:,1
OP L,,0,* ;NJCALL
OPTB OP.%LL:,2
OP LL,,0,* ;ACALL (AND TTCALL IN D10)
OPTB OP.AJC,1
OP A,OP.%LL,,* ;AJCALL
OPTB OP.FLT:,1 ;FLOATING MODIFIERS
OP R,OP.IMB,4 ; ROUNDED
OP -,,0 ; NORMAL
OP L,,1 ; LONG
OP M,,2 ; MEMORY
OP B,,3,* ; BOTH
OPTB OP.ZOE:,1 ;HALFWORD MODIFIERS
OP Z,OP.IMS,10 ; ZEROS
OP O,OP.IMS,20 ; ONES
OP E,OP.IMS,30 ; EXTEND
OPTB OP.IMS:,1 ;ADDRESSING MODES
OP -,,0 ; NORMAL
OP I,,1 ; IMMEDIATE
OP M,,2 ; MEMORY
OP S,,3,* ; SELF
OPTB OP.IMU:,1
OP L,OP.IMB,,* ;IMUL--
OPTB OP.IDI:,1
OP V,OP.IMB,,* ;IDIV--
OPTB OP.JSK:,1
OP P,OP.CND,,* ;JUMP--, SKIP--
OPTB OP.LER:,1 ;LISP ERROR UUO TYPES
OP R,,001 ; LERR
OP 3,,004,* ; LER3
OPTB OP.MOV:,1 ;MOVE MODIFIERS
OP E,OP.IMS,0 ; MOVE--
OP S,OP.IMS,4 ; MOVS--
OP N,OP.IMS,10 ; MOVN--
OP M,OP.IMS,14,* ; MOVM--
OPTB OP.ORC:,1
OP A,OP.IMB,454 ;ORCA--
OP M,OP.IMB,464 ;ORCM--
OP B,OP.IMB,470,* ;ORCB--
OPTB OP.PUS:,2
OP HJ,,0 ;PUSHJ
OP H-,,1,* ;PUSH
OPTB OP.POP:,1
OP -,,0 ;POP
OP J,,1,* ;POPJ
OPTB OP.RS:,2 ;IOJRST
OP RS,OP.RST,0,*
OPTB OP.RST:,1
OP T,,0,*
OPTB OP.SET:,1
OP Z,OP.IMB,0 ;SETZ--
OP O,OP.IMB,74 ;SETO--
OP A,OP.IMB,24 ;SETA--
OP M,OP.IMB,14 ;SETM--
OP C,OP.STC,50,* ;SETC--
OPTB OP.NDC:,1
OP B,OP.IMB,30 ;ANDCB--
OPTB OP.STC:,1
OP A,OP.IMB,0 ;ANDCA--, SETCA--
OP M,OP.IMB,10,* ;ANDCM--, SETCM--
OPTB OP.ZCO:,1 ;TEST MODIFIERS
OP N,OP.EAN,0 ; NO CHANGE
OP Z,OP.EAN,20 ; ZEROS
OP C,OP.EAN,40 ; COMPLEMENT
OP O,OP.EAN,60,* ; ONES
OPTB OP.SER:,1
OP I,OP.%NT,0,* ;SERI--
OPTB OP.%%H:,1
OP H,,0,* ;EXCH
OPTB OP.%NT:,2
OP NT,,0,* ;ERINT, SERINT
OPTB OP.%%B:,1
OP B,,0,* ;ILDB, IDPB
OPTB OP.%%T:,1
OP T,,0,* ;JRST (sail: CLKINT)
OPTB OP.%$T:,2
OP T-,,0 ;STRT
OP T7,,4,* ;STRT7
OPTB OP.%%O:,1
OP O,,0,* ;JFFO
IFN SAIL,[ ;ENTRIES FOR SAIL UUOS
OPTB OP.INT:,2
OP IN,OP.%%T,0,* ;CLKINT
OPTB OP.DPY:,2
OP CL,OP.%%R,,* ;DPYCLR
OPTB OP.%%R:,1
OP R,,0,* ;DPYCLR
OPTB OP.%YC:,2
OP LR,,701,* ;DPYCLR
OPTB OP.IOP:,2
OP DL,,2 ;IOPDL
OP OP,,1 ;IOPOP
OP US,OP.%%H,0,* ;IOPUSH
OPTB OP.MAI:,1
OP L,,710,* ;MAIL
OPTB OP.OT:,2
OP OT,,0,* ;PPIOT, PGIOT
OPTB OP.UUO:,2
OP UU,OP.%%O ;PTYUUO
OPTB OP.%UO:,2
OP UO,,0,* ;TTYUUO
OPTB OP.UPG:,2
OP IO,OP.%%T,703 ;UPGIOT
OP MV,OP.UPM,713,* ;UPGMVE
OPTB OP.UPM:,1
OP E,,0 ;UPGMVE
OP M,,1,* ;UPGMVM
]
IFN D10,[ ;MANY ENTRIES JUST FOR DECSYSTEM-10
OPTB OP.UGE:,2
OP TF,,073,* ;UGETF
OPTB OP.USE:,2
OP TI,,074 ;USETI
OP TO,,075,* ;USETO
OPTB OP.STA:,2
OP TO,,061 ;STATO
OP TZ,,063,* ;STATZ
OPTB OP.OUT:,1
OP -,,057 ;OUT
OP B,OP.%UF,065 ;OUTBUF
OP P,OP.%UT,067,* ;OUTPUT
OPTB OP.REL:,2
OP EA,OP.%%S,,* ;RELEAS
OPTB OP.REN:,2
OP AM,OP.%%E,,* ;RENAME
OPTB OP.STS:,2
OP ST,OP.%%S,,* ;GETSTS, SETSTS (sail: CHNSTS)
OPTB OP.TT:,2
SA$ OP YU,OP.%UO,0 ;TTYUUO (SAIL)
OP CA,OP.%LL,,* ;TTCALL
OPTB OP.%SE:,2
OP SE,,0,* ;CLOSE
OPTB OP.%%N:,1
OP N,,0,* ;OPEN
OPTB OP.%ER:,2
OP ER,,0,* ;ENTER
OPTB OP.%UF:,2
OP UF,,0,* ;INBUF, OUTBUF
OPTB OP.%UT:,2
OP UT,,0,* ;INPUT, OUTPUT
OPTB OP.%%P:,1
OP P,,0,* ;LOOKUP
OPTB OP.KUP:,2
OP KU,OP.%%P,,* ;LOOKUP
OPTB OP.%PE:,2
OP PE,,0,* ;MTAPE
OPTB OP.%%E:,1
OP E,,0,* ;RENAME
] ;END OF IFN D10
IFN D10+D20,[
OPTB OP.%%S:,1
OP S,,0,* ;(d10: RELEAS), (d20: JSYS)
] ;END OF IFN D10+D20
;;; OPCODE TABLE MUST HAVE LESS THAN 1000 ENTRIES
IFL OPTABL+1000-.,[
.ERR ######
PRINTX \OPCODE TABLE TOO BIG - LENGTH =\
INFORM \.-OPTABL
]
.SXEVAL (REMPROP (QUOTE SQOZ/|) (QUOTE SUBR))
.ENTRY SQOZ/| SUBR 2
5BTWD: PUSH P,CFIX1
$5BTWD: PUSH FXP,R70
5BTWD0: MOVEI C,(A)
HRRZ B,(A)
JUMPE B,5BTWD1
HLRZ A,(A)
JSP T,FXNV1
LSH TT,-2
MOVEM TT,(FXP)
MOVEI A,(B)
5BTWD1: HLRZ A,(A)
JUMPE A,5BTWD2
MOVEI T,(A)
LSH T,-SEGLOG
MOVE T,ST(T)
TLNN T,SY
JRST 5BTWD9
5BTWD2: PUSHJ P,SQUEEZE ;SHOULD LEAVE SIXBIT IN R
POP FXP,D
DPB D,[400400,,TT]
POPJ P,
5BTWD9: SETZM (FXP)
MOVEI A,(C)
WTA [BAD ARG - SQUOZE!]
JRST 5BTWD0
FASEND

2622
src/libdoc/loop.819 Normal file
View File

File diff suppressed because it is too large Load Diff

173
src/lspsrc/cerror.47 Executable file
View File

@@ -0,0 +1,173 @@
;;; CERROR -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ****************************************************************
;;; *** MacLISP ******** CERROR - pseudo version *******************
;;; ****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;; ****************************************************************
(herald CERROR /47)
(include ((lisp) subload lsp))
(eval-when (eval compile)
(subload EXTMAC)
(mapc '(lambda (x) (putprop x T 'SKIP-WARNING))
'(CERROR FERROR +INTERNAL-LOSSAGE))
(setq MACROS () )
)
(eval-when (eval load compile)
(cond ((status feature COMPLR)
(*lexpr CERROR FERROR LEXPR-SEND SI:LOST-MESSAGE-HANDLER)))
)
;;;; Kludgy MacLISP setup for ERROR-OUTPUT variable
(defvar ERROR-OUTPUT 'T)
(defun ERROR-OUTPUT-output MACRO (x) `(SFA-GET ,(cadr x) 0))
(defun si:ERROR-OUTPUT-handler (self op arg)
(let ((out (ERROR-OUTPUT-output self)))
(caseq op
((PRINT PRINC) (funcall op arg out))
(TYO (if (> arg 0) (tyo arg out)))
((FRESH-LINE :FRESH-LINE) (si:fresh-linify out))
(CURSORPOS (si:spread-cursorpos arg out))
((LINEL CHARPOS) (lexpr-funcall op out arg))
(WHICH-OPERATIONS '(PRINT PRINC TYO FRESH-LINE CURSORPOS
LINEL CHARPOS))
(T (sfa-unclaimed-message self op arg)))))
;; Now that we have a winner, override any previous ERROR-OUTPUT setting
;; which is "standard".
(cond ((and (boundp 'ERROR-OUTPUT)
(not (eq ERROR-OUTPUT 'T))
(not (eq ERROR-OUTPUT TYO))
(not (eq ERROR-OUTPUT MSGFILES)))
;; Leave this case alone -- it is set to something "local"
)
((status nofeature SFA) ;Lossage-mode
(setq ERROR-OUTPUT (subst tyo 'T msgfiles)))
(T (setq ERROR-OUTPUT (sfa-create 'si:ERROR-OUTPUT-handler
1
'ERROR-OUTPUT))
(sfa-store ERROR-OUTPUT
0
(if (boundp 'TERMINAL-IO) terminal-io TYO))))
(defun SI:LOST-MESSAGE-HANDLER (object message &rest params &aux newsym)
(if (= (getcharn message 1) #/:)
(lexpr-send object (implode (cdr (explode message))) params)
(if (and (not (= (getcharn message 1) #/:))
(find-method (setq newsym
(implode (list* #/: (explode message))))
(class-of object)))
(lexpr-send object newsym params)
(if (and (si:where-is-method 'PRINT (class-of object))
(si:where-is-method 'FLATSIZE (class-of object)))
(ferror ':UNCLAIMED-MESSAGE
"The message ~S went unclaimed by ~S.~:[~;~2G args: ~S.~]"
message object params)
(ferror
':UNCLAIMED-MESSAGE
"Message ~S not handled by object at address ~S.~%~@
~:[(object is not connected to OBJECT-CLASS)~;OBJECT-CLASS is bad!!~].
~:[~;~3G Args: ~S.~]~%"
message
(maknum object)
(si:has-superior (class-of object) OBJECT-CLASS)
params)))))
;; Dont use DEFUN& format -- so that no (ARGS 'FERROR ...) will be done.
(defun FERROR nargs (lexpr-funcall #'CERROR () () (listify nargs)))
;;;; Kludgy MacLISP definition of CERROR
(defvar CERROR-PRINTER 'FORMAT
"Function to print an error message for format. Gets ERROR-OUTPUT
followed by the format string and additional arguments. If set to NIL,
an attempt is made to create an informative string from the format string
and such, and this is used as the secod argument to ERROR.")
(defun SI:CERROR-ERROR-STRING (string
&aux (super-debug-modep (and *RSET NOUUO)))
(maknam
(nconc (exploden string)
(list '| |)
(exploden
(or (do ((i 0 (1+ i))
(f (if super-debug-modep () (cons () (baklist)))
(if super-debug-modep (evalframe (cadr f)) (cdr f)))
(fun () (if super-debug-modep (caddr f) f)))
((cond ((> i 12.) (setq fun '?))
((and (not (atom fun))
(symbolp (setq fun (car fun)))
(not (memq fun
'(CERROR FERROR SI:CHECK-TYPER
COND SETQ DO PROGN AND OR
SI:CHECK-SUBSEQUENCER))))))
fun))
'?)))))
;; Done use DEFUN& format -- so that no (ARGS 'CERROR ...) will be done.
(defun CERROR nargs
(let (((proceedable restartable condition string . cruft) (listify nargs)))
(if CERROR-PRINTER
(progn (if (symbolp CERROR-PRINTER)
(or (fboundp CERROR-PRINTER)
(+internal-try-autoloadp CERROR-PRINTER)))
(terpri error-output)
(lexpr-funcall CERROR-PRINTER error-output string cruft)))
(let* ((blurb (if CERROR-PRINTER '? (si:cerror-error-string string)))
(chnl (cond ((null condition) 'FAIL-ACT)
((caseq condition
(:WRONG-NUMBER-OF-ARGUMENTS
(setq cruft
`((,(car cruft) ,@(caddr cruft))
,(and (symbolp (car cruft))
(args (car cruft)))))
'WRNG-NO-ARGS)
(:WRONG-TYPE-ARGUMENT
(setq cruft (cadr cruft))
'WRNG-TYPE-ARG)
(:UNDEFINED-FUNCTION
(setq cruft (car cruft))
'UNDF-FNCTN)
(:UNBOUND-VARIABLE
(setq cruft (car cruft))
'UNBND-VRBL)
((:UNCLAIMED-MESSAGE :INCONSISTENT-ARGUMENTS)
(setq cruft `(,condition ,cruft))
'FAIL-ACT)
(T () ))))))
(cond ((null chnl)
(error "-- Unknown or un-proceedable condition" condition))
((and (not proceedable) (not restartable))
(error blurb cruft))
('T (setq blurb (error blurb cruft chnl))
(cond (proceedable blurb)
('T (*throw 'ERROR-RESTART () ))))))))
(defun +INTERNAL-LOSSAGE (id fun datum)
(format error-output "~%;System error, or system code incomplete: Id '~A' in function ~S.~:[~;~%; Losing datum is: ~2G~S~]"
id fun datum)
(error (list id fun datum) '+INTERNAL-LOSSAGE 'FAIL-ACT))
(mapc #'(lambda (x) (or (getl (car x) '(SUBR AUTOLOAD))
(putprop (car x) `((LISP) ,(cadr x) FASL) 'AUTOLOAD)))
'((SFA-UNCLAIMED-MESSAGE EXTSFA)
(SI:FRESH-LINIFY QUERIO)
(SI:SPREAD-CURSORPOS QUERIO)
(SI:WHERE-IS-METHOD EXTEND)
(SI:HAS-SUPERIOR EXTEND)))

133
src/lspsrc/descri.4 Executable file
View File

@@ -0,0 +1,133 @@
;;; DESCRI -*-LISP-*-
;;; ***************************************************************
;;; *** MACLISP ******** DECRIBE Function *************************
;;; ***************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ***
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES REVERSED) ********
;;; ***************************************************************
(herald DESCRIBE /3)
(declare (setq USE-STRT7 'T MACROS () ))
(defun LISPDIR macro (x)
`(QUOTE ((LISP) ,(cadr x) #+Pdp10 FASL)))
(defun SUBLOAD macro (x)
(setq x (cadr x))
`(OR (GET ',x 'VERSION) (LOAD #%(lispdir ,x))))
(eval-when (eval compile)
(subload UMLMAC)
;; Remember, EXTMAC down-loads CERROR
(subload EXTMAC)
)
(eval-when (eval load compile)
(subload EXTEND)
)
;;;; DESCRIBE -- Function and methods
(defun DESCRIBE (x &optional (stream STANDARD-OUTPUT))
(send x 'DESCRIBE stream 0)
'*)
(defmethod* (DESCRIBE object-class) (object &optional (stream STANDARD-OUTPUT)
(level 0))
(if (extendp object)
(si:describe-extend object stream level)
(si:describe-maclisp-object object stream level)))
(defun SI:describe-extend (object stream level)
(format stream '|~&~vTThe object at #~O of class ~S~:[ (type ~S),
~vT~;~*~*, ~]and is ~D Q's long.~%|
level (maknum object) (si:class-name-careful (class-of object))
(eq (si:class-name-careful (class-of object)) (type-of object))
(type-of object)
level (hunksize object)))
(defun SI:describe-maclisp-object (object stream level)
(let ((prinlevel 3) (prinlength 4))
(format stream '|~&~vT~S is a ~S~%|
level object (type-of object))))
(defvar SI:DESCRIBE-MAX-LEVEL 6) ;Describe up to 3 levels deep
(defvar SI:DESCRIBE-IGNORED-PROPS '(SUBR FSUBR LSUBR EXPR FEXPR MACRO))
(defmethod* (DESCRIBE symbol-class) (sym &optional (stream STANDARD-OUTPUT)
(level 0))
(unless (not (= level 0))
(unless (> level si:describe-max-level)
(cond ((boundp sym)
(let ((prinlevel 2) (prinlength 3))
(format STANDARD-OUTPUT
'|~&~vTThe value of ~S is ~S| level sym (symeval sym)))
(send (symeval sym) 'describe stream (+ 2 level))))
(cond ((getl sym '(SUBR FSUBR LSUBR EXPR FEXPR MACRO))
(let ((prinlevel 2) (prinlength 3))
(format STANDARD-OUTPUT
'|~&~vT~S is defined as a ~S; Args: ~S|
level sym (car (getl sym '(EXPR FEXPR LSUBR SUBR FSUBR
MACRO AUTOLOAD)))
(args sym)))))
(do ((pl (plist sym) (cddr pl))
(prinlevel 2)
(prinlength 3))
((null pl))
(unless (memq (car pl) si:describe-ignored-props)
(format STANDARD-OUTPUT '|~&~vT~S has property ~S: ~S|
level sym (car pl) (cadr pl))
(send (cadr pl) 'DESCRIBE stream (+ 2 level)))))))
(defmethod* (DESCRIBE class-class) (class &optional (stream STANDARD-OUTPUT)
(level 0))
(format stream '|~&~vTThe class ~S has TYPEP of ~S
~vTDocumentation: ~:[[Missing]~;~4G~A~]
~vTSuperiors: ~S
~vTClass-var: ~S
~vTPlist: ~S|
level class (si:class-typep class)
level (si:class-documentation class)
level (si:class-superiors class)
level (si:class-var class)
level (cdr (si:class-plist class)))
(format stream '|
~vTMethods: ~:[[None]~;~1G~{~S ~}~]|
level (do ((methods (si:class-methods class)
(method-next methods))
(ll () (cons (method-symbol methods) ll)))
((null methods) (nreverse ll))))
(mapc #'(lambda (class)
(send class 'describe stream (+ 2 level)))
(si:class-superiors class)))
;;;; WHICH-OPERATIONS function
(defun WHICH-OPERATIONS (class &aux methods-seen (object class))
(declare (special methods-seen))
(unless (classp object)
(setq class (class-of object))
(format STANDARD-OUTPUT
'|~&[~S is of class ~S]~%| object class))
(mapc #'(lambda (meth)
(unless (memq (car meth) methods-seen)
(push (car meth) methods-seen)
(format STANDARD-OUTPUT
'|~&~S~18T ==> ~S~52T in ~S~%|
(car meth) (cadr meth)
(si:class-name-careful (caddr meth)))))
(si:operations-list class))
() )

75
src/lspsrc/dumpar.8 Executable file
View File

@@ -0,0 +1,75 @@
;;; DUMPAR -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** LOADARRAYS AND DUMPARRAYS ***************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(herald DUMPAR /8)
(DECLARE (SPECIAL AFILE EOFP))
(DEFUN LOADARRAYS (AFILE)
(PROG (FILE ARRAYS-LIST EOFP CNT L M FILENAME NEWNAME)
(DECLARE (FIXNUM CNT M))
(SETQ FILE (OPEN AFILE '(IN BLOCK FIXNUM)))
(EOFFN FILE 'LOADARRAYS-FILE-TRAP)
(*CATCH 'LOADARRAYS
(PROG ()
1A (SETQ EOFP T M (IN FILE))
(COND ((= M #o14060301406)
;Stop on a word of ^C's, for compatibility with OLDIO
(*THROW 'LOADARRAYS () )))
(SETQ CNT (logand M #o777777))
;Number of wds in pname for array
(OR (= CNT (logand (- (LSH M -18.)) #o777777))
(ERROR FILE '|FILE NOT IN DUMPARRAYS FORMAT|))
(SETQ EOFP NIL NEWNAME (GENSYM) L NIL)
LP (COND ((NOT (MINUSP (SETQ CNT (1- CNT))))
(SETQ L (CONS (IN FILE) L))
(GO LP)))
(SETQ FILENAME (PNPUT (NREVERSE L) T))
(SETQ CNT (IN FILE)
M (logand CNT #o777777) ;Type for array
CNT (logand (- (LSH CNT -18.)) #o777777)) ;Total # of wds
(*ARRAY NEWNAME
(COND ((= M 1) 'FIXNUM) ((= M 2) 'FLONUM) (T NIL))
CNT)
(FILLARRAY NEWNAME FILE)
(SETQ ARRAYS-LIST
(CONS (LIST NEWNAME FILENAME CNT)
ARRAYS-LIST))
(GO 1A)))
(CLOSE FILE)
(RETURN (NREVERSE ARRAYS-LIST))))
(DEFUN LOADARRAYS-FILE-TRAP (X)
(COND (EOFP (*THROW 'LOADARRAYS () ))
(T (ERROR '|FILE NOT IN DUMPARRAYS FORMAT|
(CONS 'LOADARRAYS AFILE) 'IO-LOSSAGE))))
(defun DUMPARRAYS (ars x)
(let ((afile (open (mergef '((*) _LISP_ _DUMP_) x) '(OUT BLOCK FIXNUM))))
(mapc #'DUMP1ARRAY ars)
(renamef afile x)))
(DEFUN DUMP1ARRAY (AR)
(PROG (LN PNLIST AD)
(DECLARE (FIXNUM LN))
(SETQ LN (LENGTH (SETQ PNLIST (PNGET AR 7)))
AD (ARRAYDIMS AR))
(OUT AFILE (logior LN (LSH (- LN) 18.))) ;OUTPUT LENGTH OF PNAME
(SETQ LN (APPLY '* (CDR AD)))
A (COND (PNLIST (OUT AFILE (CAR PNLIST)) ;OUTPUT WDS OF PNAME
(SETQ PNLIST (CDR PNLIST))
(GO A)))
(OUT AFILE (logior (LSH (- LN) 18.) ;KEY WD
(COND ((EQ (CAR AD) 'FIXNUM) 1)
((EQ (CAR AD) 'FLONUM) 2)
(T 0))))
(FILLARRAY AFILE AR)))

645
src/lspsrc/edit.37 Executable file
View File

@@ -0,0 +1,645 @@
;;; -*-MIDAS-*-
;;; **************************************************************
;;; ***** MACLISP ****** KLUDGY BINFORD EDITOR *******************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
.FASL
IF1,[
.INSRT SYS:.FASL DEFS
10% .INSRT DSK:SYSTEM;FSDEFS >
10$ .INSRT LISP;DECDFS >
10$ .DECDF
NEWRD==0
] ;END OF IF1
TMPC==0 ;TEMPORARY I/O CHANNEL IN NEWIO
VERPRT EDIT,37
.SXEVAL (SETQ EDPRFL/| T EDPRN/| #11. EDSRCH/| ()
EDLP/| (COPYSYMBOL (QUOTE %I/(%) ())
EDRP/| (COPYSYMBOL (QUOTE %I/)%) ())
EDSTAR/| (COPYSYMBOL (QUOTE %D/(/)%) ())
EDEX2-SB/| () EDEX2-INDEX/| #0 ^^^ () )
.SXEVAL (AND (OR (NOT (BOUNDP (QUOTE EDIT))) (NULL EDIT))
(SETQ EDIT (QUOTE (EXPR FEXPR MACRO))))
.SXEVAL (SSTATUS FEATURE EDIT)
SUBTTL KLUDGY BINFORD EDITOR
EDPRW==13 ;PRINT WIDTH,PRINT N ATOMS ON
;EITHER SIDE OF POINTER
R4==AR1
R5==AR2A
R6==T
.ENTRY EDIT FSUBR 0
$EDIT: MOVE B,A
JSP D,BRGEN ;ERRSET LOOP
JUMPE B,EDTTY
HLRZ A,(B)
PUSH P,CEDTTY
JRST EDY0
EDTTY: SKIPE .SPECIAL EDPRFL/|
PUSHJ P,EDPRINT
EDTTY4: MOVEI C,0 ;INIT NUMBER
MOVEI B,0 ;INIT SYMBOL,NUMBERS COME HERE
MOVE R4,[220600,,B] ;SETUP BYTEP
EDTYIN: SAVE B C R4
NCALL 0,.FUNCTION *TYI
RSTR R4 C B
MOVE R5,.SPECIAL READTABLE
MOVE R5,@TTSAR(R5)
NW% TLNN R5,4
NW$ TRNN R5,RS.DIG
JRST EDTTY1 ;NOT NUMBER
EDNUM: IMULI C,10. ;ACCUMULATE DECIMAL NUMBER
NW% ADDI C,-"0(R5)
NW$ ANDI R5,777
NW$ ADDI C,-"0(R5)
JRST EDTYIN
EDTTY1: CAIE TT,15
CAIN TT,12
JRST EDTYIN
CAIE TT,33
CAIN TT,177
JRST EDTTY3
CAIN TT,40
JRST EDTTY2
NW% TLNN R5,377777
NW$ TDNN R5,[001377777000] ;??
JRST EDTYIN
NW% TLNN R5,70053 ;LEGIT CHARS ARE <ALPHA> ( ) - , .
NW$ TDNN R5,[RS.LTR+RS.XLT+RS.LP+RS.RP+RS.DOT+RS.SGN+RS.ALT] ;RS.ALT??
JRST EDERRC
ADDI R5,40
TLNE R4,770000 ;SIXBIT THREE CHARS
IDPB R5,R4
JRST EDTYIN ;READ NEXT CHAR
EDTTY2: JUMPE B,EDTYIN ;IGNORE LEADING SPACES
PUSHJ P,EDSYM
JRST EDTTY
EDTTY3: SKIPE .SPECIAL EDPRFL/|
STRT7 [ASCII \î  î!\]
JRST EDTTY4
;SEARCH SYMBOL TABLE
EDSYM: MOVEI R5,EDSYML-1
EDSYM1: MOVS R6,EDSYMT(R5)
CAIE B,(R6)
SOJGE R5,EDSYM1
JUMPL R5,EDSYM3
MOVE R4,R5
ADDI R4,IN0
MOVEM R4,.SPECIAL EDEX2-INDEX/|
MOVSS R6
CAIL R5,EDRPT
JRST (R6)
EDEX1: PUSH P,C
MOVE R6,@.SPECIAL EDEX2-INDEX/|
MOVE R6,EDSYMT(R6)
PUSHJ P,(R6) ;EXECUTE COMMAND
SOSLE C,(P)
JUMPN A,.-4
EDEX3: POP P,B
POPJ P,
EDSYM3: PUSH FXP,C
MOVE C,[440700,,PNBUF]
MOVE R4,[440600,,B]
MOVSI B,(B)
SETOM LPNF
SETZM PNBUF
JRST EDSYM5
EDSYM4: ADDI A,40
IDPB A,C
EDSYM5: ILDB A,R4
JUMPN A,EDSYM4
PUSHJ P,RINTERN
MOVEI B,.ATOM EDIT
CALL 2,.FUNCTION GET
POP FXP,TT
JUMPE A,EDERRC
MOVEI AR1,(A)
JSP T,FXCONS
JCALLF 1,(AR1)
EDERRC: STRT [SIXBIT \?? !\]
CEDTTY: JRST EDTTY
EDSYMT: ;COMMAND TABLE
EDSYMB: +(SIXBIT \B\),,EDB ;BACK,LEFT PAST ATOM
+(SIXBIT \D\),,EDDOWN ;DOWN
EDSYMF: +(SIXBIT \F\),,EDF ;FORWARD,RIGHT ATOM
+(SIXBIT \U\),,EDUP ;UP
+(SIXBIT \L\),,EDLL ;LEFT PAST S-EXPR
+(SIXBIT \R\),,EDRR ;RIGHT PAST S-EXPR
+(SIXBIT \K\),,EDKILL ;KILL
+(SIXBIT \-K\),,EDLKILL ;LEFT, THEN KILL
+(SIXBIT \-L\),,EDRR
+(SIXBIT \-R\),,EDLL
+(SIXBIT \PW\),,EDPW ;SET PRINT WIDTH
EDSYMP: +(SIXBIT \PQ\),,EDPRA ;INTERNAL PRINT
+(SIXBIT \EV\),,REP ;EVAL
+(SIXBIT \I\),,EDI ;INSERT
+(SIXBIT \KI\),,EDKI ;REPLACE,I E KILL INSERT
+(SIXBIT \-KI\),,EDMKI ;REPLACE TO LEFT
+(SIXBIT \IV\),,EDIV ;INSERT VALUE OF ARG
+(SIXBIT \P\),,EDPR0 ;PRINT
+(SIXBIT \Q\),,EDQ ;QUIT,EXIT FROM EDIT
+(SIXBIT \S\),,EDS ;SEARCH
+(SIXBIT \SS\),,EDSAVE ;SAVE SPOT
+(SIXBIT \RS\),,EDRSTR ;RESTORE SPOT
+(SIXBIT \SP\),,EDCHPR ;START-PRINTING (OR STOP-PRINTING)
+(SIXBIT \J\),,EDTOP ;TOP
+(SIXBIT \Y\),,EDY ;YANK
+(SIXBIT \YP\),,EDYP ;YANK PROP LIST, OR SPECIFIC PROPERTY
+(SIXBIT \YV\),,EDYV ;YANK VALUE
+(SIXBIT \(\),,EDLP. ;INSERT VIRTUAL LEFT PAREN
+(SIXBIT \)\),,EDRP. ;INSERT VIRTUAL RIGHT PAREN
+(SIXBIT \D(\),,EDXLP ;VIRTUAL DELETION OF PAREN
+(SIXBIT \D)\),,EDXLP ;VIRTUAL DELETION OF PAREN
+(SIXBIT \()\),,EDZZ ;RESTRUCTURE ACCORDING TO VIRTUAL PARENS
EDSYML==.-EDSYMT
EDRPT==EDSYMP+1-EDSYMT ;NO REPEAT FOR COMMANDS ABOVE EDSYMP
;EDIT MANIPULATES TWO LISTS FOR BACKING UP
;THE LEFT LIST CALLED L (VALUE OF  (3 ALTMODES))
;RIGHT: (COND ((PTR (CAR L)) (SETQ L (CONS (CDAR L) L))))
;LEFT: (COND ((PTR L) (SETQ L (CDR L))))
;THE UP LIST U (KEPT AT EDUPLST)
;DOWN: (COND ((AND (PTR (CAR L)) (PTR (CAAR L)))
; (SETQ U (CONS L U))
; (SETQ L (LIST L))))
;UP: (COND ((PTR U) (SETQ L (CAR U))
; (SETQ U (CDR U))))
EDQ: MOVEI A,.ATOM *
MOVEI B,.ATOM BREAK
JRST ERUNDO-1 ;THROW OUT OF BREAK ERRSET LOOP
;RIGHT PAST S-EXPR
;USES ONLY A,B ;NIL IF FAILS
EDR: PUSHJ P,EDCAR
JRST EFLSE ;NOT A PTR
HRRZ A,(A) ;TAKE CDAR L
HRRZ B,.SPECIAL 
CALL 2,.FUNCTION CONS ;CONS ONTO L
EDR1: HRRZM A,.SPECIAL  ;STORE IN L
POPJ P, ;NON-ZERO,VALUE EDIT
EDLEFT: SKIPE A,.SPECIAL  ;TAKE CDR IF NON-NIL
HRRZ A,(A)
JUMPE A,EFLSE
JRST EDR1
;DOWN ONE LEVEL
;USES ONLY A,B
;NIL IN A IF FAILS
EDDOWN: PUSHJ P,EDCAAR ;IS (CAAR L) A PTR
JRST EFLSE ;NOT PTR
CALL 1,.FUNCTION NCONS
EXCH A,.SPECIAL  ;STORE IN L
HRRZ B,.SPECIAL ^^^
CALL 2,.FUNCTION CONS ;CONS L U
EDD1: HRRZM A,.SPECIAL ^^^ ;STORE IN U
POPJ P, ;NON-ZERO
;BACK
EDB: PUSHJ P,EDLEFT ;LEFT?
JUMPE A,EDUP
PUSHJ P,EDCAAR ;NEXT IS ATOM?
JRST EDTRUE
EDB1: PUSHJ P,EDDOWN ;DOWN
JUMPE A,EDUP
EDXR: PUSHJ P,EDR ;EXTREME RIGHT
JUMPN A,.-1
JRST EDTRUE
;FORWARD
;RIGHT ATOM
EDF: PUSHJ P,EDCAR ;CAR L PTR?
JRST EDF2 ;NOT PTR
PUSHJ P,EDCAR1 ;(CAAR L) ATOM
JRST EDR ;ATOM,GO RIGHT
EDF1: PUSHJ P,EDDOWN ;DOWN?
JUMPN A,CPOPJ
EDF2: PUSHJ P,EDUP ;UP?
JUMPN A,EDR ;AND RIGHT?OTHERWISE FALLS THROUGH TO EDUP
EDUP: SKIPN A,.SPECIAL ^^^ ;UP ONE LEVEL
JRST EFLSE
MOVE A,(A)
JUMPE A,EFLSE
HLRZM A,.SPECIAL  ;L=(CAR U)
JRST EDD1
EFLSE: TDZA A,A
EDTRUE: MOVEI A,.ATOM T
POPJ P,
EDRR: PUSHJ P,EDR
JUMPN A,CPOPJ
JRST EDF
EDLL: PUSHJ P,EDLEFT
JUMPN A,CPOPJ
JRST EDUP
REP: PUSHJ P,EIREAD
CALL 1,.FUNCTION *EVAL
JCALL 1,.FUNCTION READ-EVAL-*-PRINT
EDPR0: SKIPE .SPECIAL EDPRFL/|
POPJ P,
EDPRINT: PUSH P,.SPECIAL 
PUSH P,.SPECIAL ^^^ ;SAVE CURRENT LOCATION
CALL 0,.FUNCTION *TERPRI
MOVN C,@.SPECIAL EDPRN/| ;ATOM COUNT
PUSHJ P,EDB ;MOVE BACK N TOKENS
JUMPE A,.+2
AOJL C,.-2
ADD C,@.SPECIAL EDPRN/| ;PRINT FORWARD 2N ATOMS
ADD C,@.SPECIAL EDPRN/|
MOVEI T,IN0+<EDSYMP-EDSYMT>
MOVEM T,.SPECIAL EDEX2-INDEX/|
SKIPE @.SPECIAL EDPRN/|
PUSHJ P,EDEX1
CALL 0,.FUNCTION *TERPRI
EDPRX: POP P,.SPECIAL ^^^ ;RESTORE CURRENT LOCATION
POP P,.SPECIAL 
POPJ P,
EDPRA: MOVSI T,400000
CAME C,@.SPECIAL EDPRN/| ;CURRENT LOCATION?
JRST .+3
STRT7 [ASCII \  \]
SETZM .SPECIAL EDEX2-SB/|
SKIPN A,.SPECIAL 
JRST EDF ;EXIT IF NOTHING MORE
PUSH P,.-1 ;PRINT ONE TOKEN AND MOVE FORWARD
PUSHJ P,EDCAR1 ;(CAR L) A PTR
JRST EDPRG
SKIPE .SPECIAL EDEX2-SB/|
STRT [SIXBIT \ !\] ; CALL REQUESTED IT
MOVE T,.ATOM T
MOVEM T,.SPECIAL EDEX2-SB/| ;ASSUMING NEXT IS ATOM, ASK FOR SPACE
PUSHJ P,EDCAR1
JRST EIPRIN1 ;(CAAR L) IS ATOM, SO PRIN1 IT
SETZM .SPECIAL EDEX2-SB/|
MOVEI A,IN0+"( ;AND BEGIN PRINTING A LIST
JCALL 1,.FUNCTION *TYO
EDPRG: MOVE T,.ATOM T ;SINCE THIS SECTIONS ENDS BY PRINTING
MOVEM T,.SPECIAL EDEX2-SB/| ;ASSUMING NEXT IS ATOM, ASK FOR SPACE
JUMPE A,EDPRG1 ;A ")", THEN REQUEST SPACE ON NEXT
STRT [SIXBIT \ . !\]
PUSHJ P,EIPRIN1
EDPRG1: MOVEI A,IN0+")
JCALL 1,.FUNCTION *TYO
EDSAVE: CALL 0,.FUNCTION *-READ-EVAL-PRINT ;SAVE CURRENT EDITING SPOT AS THE VALUE OF SOME ATOM
SKIPN AR1,A
JRST EDERRC
CALL 1,.FUNCTION TYPEP
CAIE A,.ATOM SYMBOL
JRST EDERRC
MOVE A,.SPECIAL 
MOVE B,.SPECIAL ^^^
CALL 2,.FUNCTION CONS
JSP T,.SET
POPJ P,
EDRSTR: CALL 0,.FUNCTION *-READ-EVAL-PRINT ;SET CURRENT EDITINT SPOT TO THAT SAVED UP IN SOME ATOM
CALL 1,.FUNCTION *EVAL
HLRZ B,(A)
MOVEM B,.SPECIAL 
HRRZ A,(A)
MOVEM A,.SPECIAL ^^^
POPJ P,
EDCHPR: SKIPE .SPECIAL EDPRFL/|
TDZA T,T
MOVEI T,.ATOM T
MOVEM T,.SPECIAL EDPRFL/|
POPJ P,
EDPW: PUSH FXP,TT
MOVE TT,C
JSP T,FIX1A
MOVEM A,.SPECIAL EDPRN/| ;SET PRINT WIDTH
POP FXP,TT
MOVEI A,NIL
EPOPJ1: POP P,T
JRST 1(T)
EDCAAR: PUSHJ P,EDCAR
EDCAR: SKIPE A,.SPECIAL 
EDCAR1: HLRZ A,(A) ;MUST PRESERVE T FOR EDPRA
SKIPN TT,A
POPJ P, ;SKIP IF TYPEP IS "LIST"
LSH TT,-SEGLOG
SKIPL TT,ST(TT)
POPJ P,
TLNN TT,ST.HNK
AOS (P)
POPJ P,
;INSERT:(SETQ L2(CAR L))
; (COND((LEFT)(RPLACD(CAR L)(CONS I L2))
; (RIGHT)(RIGHT))
; ((UP)(RPLACA(CAR L)(CONS I L2))
; (DOWN)(RIGHT)))
;KILL:(SETQ L2(CAR L))
; (COND((LEFT)(RPLACD(CAR L)(CDR L))
; (RIGHT))
; ((UP)(RPLACA(CAR L)(CDR L2))
; (DOWN)))
;INSERT ONE S-EXPR
;USES A,B AND WHATEVER READ SMASHES
EDI: PUSHJ P,EDREAD ;GET S-EXPR
EDIB: MOVEI D,EDIA
JRST EDMAP
EDIV: CALL 0,.FUNCTION *-READ-EVAL-PRINT
CALL 1,.FUNCTION *EVAL
MOVE B,A
EDIA: SKIPE A,.SPECIAL 
HLRZ A,(A)
EDIC: CALL 2,.FUNCTION XCONS
MOVE B,A
EDID: PUSHJ P,EDK1
JRST EDR
EDLKILL: PUSHJ P,EDLEFT
JUMPE A,CPOPJ
EDKILL:
EDKA: PUSHJ P,EDCAR ;KILL ONE S-EXP
SKIPA B,A ;USES A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZM A,.SPECIAL 
EDK1: PUSHJ P,EDLEFT ;LEFT?
JUMPE A,EDI2
PUSHJ P,EDCAR
JRST EDI2
HRRM B,(A) ;(RPLACD (CAR L) Q)
EDK2: JRST EDR
;RETURNS NIL IF FAILS
EDI2: PUSHJ P,EDUP ;UP?
JUMPE A,EFLSE
PUSHJ P,EDCAR ;IS (CAR L) POINTER
JRST EFLSE
HRLM B,(A) ;(RPLACA (CAR L) Q)
EDI3: JRST EDDOWN
EDRDATOM: CALL 0,.FUNCTION *-READ-EVAL-PRINT
MOVE B,A
CALL 1,.FUNCTION ATOM
JUMPE A,EDERRC
MOVEI A,(B)
POPJ P,
EDY: PUSHJ P,EDRDATOM
EDY0: MOVE B,.SPECIAL EDIT
CALL 2,.FUNCTION GETL
JUMPE A,EDERRC
EDYX: CALL 1,.FUNCTION NCONS
EDYX1: SETZM .SPECIAL ^^^
JRST EDR1
EDYV: PUSHJ P,EDRDATOM
MOVEI B,.ATOM VALUE
JRST EDY2A
EDYP: PUSHJ P,EDREAD
HRRZ B,(A)
JUMPE B,EDY1
HLRZ A,(A)
EDY2: HLRZ B,(B)
EDY2A: MOVEI C,(B)
CAIN C,.ATOM VALUE
JRST EDY3
CALL 2,.FUNCTION GET
JRST EDYX
EDY1: HLRZ A,(A) ;GET ATOM READ
HRRZ A,(A) ;GET ITS PLIST
JRST EDYX
EDY3: NCALL 1,.FUNCTION VALUE-CELL-LOCATION
HRRZ A,(TT)
CAIN A,QUNBOUND
JRST EDERRC
JRST EDYX
;READS A STRING OF S-EXPRS TERM BY 
;FORMS A LIST IN PROPER DIRECTION
EDREAD: PUSHJ P,EIREAD ;GET S-EXPR
CAIN A,.ATOM  ; TERMINATES
JRST EFLSE
PUSH P,A
PUSHJ P,EDREAD ;FORM LIST BY RECURSION
POP P,B
JCALL 2,.FUNCTION XCONS
EIREAD: MOVEI T,0
SKIPE .SPECIAL READ
JCALLF 16,@.SPECIAL READ
JCALL 0,.FUNCTION *-READ-EVAL-PRINT
EIPRIN1: SKIPN T,.SPECIAL PRIN1
JCALL 1,.FUNCTION *PRIN1
JCALLF 1,(T)
;SEARCH
;PERMITS SEARCH FOR FRAGMENTS OF AN
;S-EXPR. FORMATS 3S A B C 
;3S A B C /)  OR S /( X Y Z 
EDS: PUSH P,.SPECIAL 
PUSH P,.SPECIAL ^^^ ;SAVE ORIGINAL LOCATION
PUSH P,C ;SAVE COUNT
PUSHJ P,EDREAD ;READ STRING OF S-EXPRS
JUMPN A,.+2
SKIPA A,.SPECIAL EDSRCH/|
MOVEM A,.SPECIAL EDSRCH/|
PUSH P,A ;SAVE READ LIST
EDS1: PUSH P,.SPECIAL 
PUSH P,.SPECIAL ^^^
EDS11: MOVE A,-2(P) ;ARG IN B
MOVEI D,EDS3
PUSHJ P,EDMAP ;DOES CURRENT LOC MATCH?
JUMPN A,EDSN ;WE HAVE A MATCH
EDS1A: POP P,.SPECIAL ^^^
POP P,.SPECIAL 
PUSHJ P,EDF ;NO MATCH,GO RIGHT ATOM
JUMPN A,EDS1 ;FINISHED,SEARCH FAILS
EDSF: SUB P,R70+2
JRST EDPRX ;EXIT RESTORE ORIG LOC
EDSN: SOSLE -3(P) ;DECREMENT COUNT
JRST EDS11 ;NOT FININSHED,MATCH AGAIN
SUB P,R70+6 ;RESTORE PDL
JRST EFLSE ;TO AVOID REPEATS BY EDEV
;TEST CURRENT LOCATION
;A IS QUANTITY TO TEST
;(CAR L) IS THE CURRENT LIST
;(COND
; ((NULL(PTR(CAR L)))
; (COND((EQ A(QUOTE /) ))(RIGHTA))))
; ((NULL(PTR(CAAR L)))
; (COND((EQ A(CAAR L))(RIGHTA))))
; ((EQUAL A(CAAR L))(RIGHT))
; ((EQ A(QUOTE /())(RIGHTA)))
;TEST CURRENT LOCATION
;ARG A IS IN B
EDS3: PUSHJ P,EDCAR ;IS(CAR L)POINTER
JRST EFLSE
HLRZ A,(A)
CALL 2,.FUNCTION EQUAL ;(EQUAL A(CAAR L))
JUMPE A,EFLSE
JRST EDR
;MAP DOWN LIST
EDMAP: MOVE R,A
EDMAP2: JUMPE R,EDTRUE
HLRZ B,(R) ;TAKE CAR
PUSHJ P,(D) ;FUNARG
JUMPE A,CPOPJ ;MATCH FAILS
HRRZ R,(R)
JRST EDMAP2
EDTOP: MOVEI C,100000
HLRZ B,EDSYMB
JRST EDSYM
EDMKI: PUSHJ P,EDLEFT
JUMPE A,CPOPJ
EDKI: CALL 0,.FUNCTION *-READ-EVAL-PRINT
EDKI1: MOVE B,A
PUSHJ P,EDCAR ;IF PTR IS ATOM RPLACD
JRST EDID
; HRRZ C,(A) ;I THINK THESE SCREW UP TOTALLY - GLS
; HLRZ C,(C)
; HRRZM C,.SPECIAL 
HRLM B,(A) ;RPLACA
JRST EDR
; ;(CAAR L) ATOM MATCH ONLY (EQ A(CAAR L))
;EDS3B: CAME A,B
; JRST EFLSE
; JRST EDR
; ;CURRENT LIST FINISHED,CAN ONLY MATCH /)
;EDS3A: JUMPN A,EDS3B
; CAIN B,RPAREN
; JRST EDF
; JRST EFLSE
;EDIP: PUSHJ P,EDCAR ;INSERT PARENS
; JUMPN A,EFLSE ;AROUND NEXT ELEMENT
; HLRZ A,(A)
; PUSHJ P,NCONS
; JRST EDKI1
;
;EDDP: PUSHJ P,EDCAAR ;DELETE PARENS
; JRST EFLSE
; PUSHJ P,EDIB
; JRST EDKA
EDRP.: SKIPA B,.SPECIAL EDRP/|
EDLP.: MOVE B,.SPECIAL EDLP/| ;INSERT VIRTUAL LEFT PAREN
JRST EDIA
EDXLP: MOVE B,.SPECIAL EDSTAR/| ;INSERT CHAR TO DELETE NEXT PAREN
JRST EDIA
EDZZ: PUSHJ P,EDTOP ;RESTRUCTURE W/ VIRTUAL PARENS
PUSHJ P,EDF
PUSHJ P,EDXA
PUSH P,A
PUSHJ P,EDTOP
PUSHJ P,EDF
POP P,A
JRST EDKI1
EDXE: SKIPE A,.SPECIAL ^^^
PUSHJ P,EDF
EDXZ: SKIPE A,.SPECIAL ^^^
EDXA: PUSHJ P,EDF ;FORWARD
EDXX: SKIPE A,.SPECIAL ^^^
PUSHJ P,EDCAR ;(PTR(CAR L))
POPJ P, ;ATOM(CAR L)
HLRZ B,(A) ;(CAAR L)
CAMN B,.SPECIAL EDRP/| ;IS IS /)?
JRST EFLSE ;SKIP AND RETURN FALSE
CAMN B,.SPECIAL EDSTAR
JRST EDXE
; CAIN B,EDDOT ;IS IT /.?
; JRST EDXD ;SKIP AND (EDXX(CAR A))
PUSH P,A
PUSHJ P,EDCAAR
PUSHJ P,EDXY
EDXG: PUSHJ P,EDXZ ;CONS(EDXX(CAR A))(EDXX(CDR A)))
EDXGA: PUSH P,A
PUSHJ P,EDXZ
POP P,C
POP P,B
HRLM C,(B) ;RPLACA A (EDXX(CAR A))
HRRM A,(B)
EXPOP: EXCH A,B
POPJ P,
EDXY: CAME A,.SPECIAL EDLP/|
JRST EPOPJ1
POPJ P,
FASEND

85
src/lspsrc/extbas.39 Executable file
View File

@@ -0,0 +1,85 @@
;;; EXTBAS -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ****************************************************************
;;; *** MacLISP **** EXTended datatype scheme, BASic functions *****
;;; ****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;; ****************************************************************
(herald EXTBAS /39)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload EXTMAC)
(subload DEFSETF)
)
;; Be careful about circular dependencies! Luckily this one is minor,
;; and can be patched, if necessary. (EXTEND has some SETFs in it.)
;; DEFSETF -> DEFVST -> EXTEND -> EXTMAC -> DEFSETF
(defsetf SI:XREF ((() h n) val) () `(SI:XSET ,h ,n ,val))
;; Used by typical NIL-compatibility functions
(defun SI:NON-NEG-FIXNUMP (n) (and (fixnump n) (>= N 0)))
;; Used by extend conser error checking
(defun SI:MAX-EXTEND-SIZEP (n) (and (fixnump n) (>= N 0) (< n 510.)))
;;;; Regular DEFUNitions of XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.
;;; SOURCE-TRAN's for XREF, XSET, MAKE-EXTEND, EXTEND-LENGTH etc.
;;; come in from exthuk file
(eval-when (eval compile load)
(if (status feature COMPLR)
(subload EXTHUK))
)
;; Pass the buck to the CXR function on error checking for these guys.
(defun SI:XREF (h n)
(subrcall T #,(get 'CXR 'SUBR) (+ #.si:extend-q-overhead n) h))
(defun SI:XSET (h n val)
(subrcall T #,(get 'RPLACX 'SUBR) (+ #.si:extend-q-overhead n) h val))
(defun SI:MAKE-EXTEND (n clss)
(if (or (or (not (fixnump n)) (< n 0) (> n 510.))
(not (classp clss)))
(cond ((fboundp 'SI:CHECK-TYPER)
(check-type n #'SI:MAX-EXTEND-SIZEP 'SI:MAKE-EXTEND)
(check-type clss #'CLASSP 'SI:MAKE-EXTEND))
('T (error '|Bad args to SI:MAKE-EXTEND| (list n clss)))))
;;Note that this must be open-compiled, either because it has a
;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
(si:make-extend n clss))
(defun SI:make-random-extend (n &optional clss)
(si:make-extend n clss))
(defun SI:EXTEND-LENGTH (x)
(if (and *RSET (not (extendp x)))
(cond ((fboundp 'SI:CHECK-TYPER)
(check-type x #'EXTENDP 'SI:EXTEND-LENGTH))
('T (error '|Not an EXTEND| x))))
;;Note that this must be open-compiled, either because it has a
;; MACRO definition, or a SOURCE-TRANS property (from EXTHUK file).
(si:extend-length x))
(let ((x (getl 'SI:EXTEND-LENGTH '(EXPR SUBR))))
(putprop 'EXTEND-LENGTH (cadr x) (car x)))
(defun SI:EXTEND n
(let ((size (1- n))
(clss (if (>= n 1) (arg 1))))
(declare (fixnum size))
(do ((obj (si:make-extend size clss))
(i 0 (1+ i)))
((>= i size) obj)
(declare (fixnum i))
;;(ARG 1) is class obj, (ARG 2) is first elt
(si:xset obj i (arg (+ i 2))))))

598
src/lspsrc/extend.292 Executable file
View File

@@ -0,0 +1,598 @@
;;; EXTEND -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ****************************************************************
;;; *** MacLISP ******** EXTENDed datatype scheme ******************
;;; ****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;; ****************************************************************
(herald EXTEND /292)
;;; In MACLISP, the term "EXTEND" refers to data objects not natively
;;; supported by Maclisp which are implemented using HUNKs according
;;; to the (STATUS USRHUNK) feature); primarily, it is the NIL data
;;; types and class sytems which is being supported.
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload EXTMAC) ;; Remember, EXTMAC down-loads CERROR
)
(eval-when (eval load compile)
(subload SENDI)
(let ((x (get 'EXTSTR 'VERSION)))
(cond ((or (null x) (alphalessp x "91"))
(remprop 'EXTSTR 'VERSION)
(let ((FASLOAD () ))
(load (autoload-filename EXTSTR))))))
(subload EXTBAS) ;Defines SI:XREF, SI:XSET, etc. Also loads EXTHUK.
(cond ((status FEATURE COMPLR)
(*lexpr SEND SEND-AS LEXPR-SEND LEXPR-SEND-AS
Y-OR-N-P YES-OR-NO-P SI:LOST-MESSAGE-HANDLER)
(fixnum (SI:HASH-Q-EXTEND))))
)
;;; SI:EXTSTR-SETUP-CLASSES is set up by EXTMAC, and includes things
;;; like CLASS-CLASS OBJECT-CLASS STRUCT=INFO-CLASS STRUCT-CLASS VECTOR-CLASS
(eval-when (eval compile load)
(cond ((status feature COMPLR)
#.`(SPECIAL ,.si:extstr-setup-classes)
(special SI:SKELETAL-CLASSES)))
)
;; There should be no user-level macro definitions in this file
(declare (setq DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () )
(setq USE-STRT7 'T MACROS () ))
;; These are just to stop silly warning msgs about redefining.
(declare (own-symbol PTR-TYPEP))
;; This is to prevent COMPLR from trying to autoload in this function
;; when a usage of it appears in the file (due to DEFCLASS*'s or
;; to DEFMETHOD*'s)
(declare (own-symbol FIND-METHOD ADD-METHOD SI:DEFCLASS*-1))
;;;; Defvars, and some Typical EXTEND functions
(defvar *:TRUTH 'T) ;In MACLISP, provide for necessary stuff
(defvar STANDARD-OUTPUT T)
;; Just to be sure that error output can go somewhere. A more substantial
;; definition is in the QUERIO file
(defvar ERROR-OUTPUT 'T)
(defvar /#-MACRO-DATALIST () )
(defun |EX-#-MACRO-T| (() ) *:TRUTH)
;; An open-coding of SETSYNTAX-SHARP-MACRO
(let ((x (get 'SHARPM 'VERSION))
(y '(#/T () MACRO . |EX-#-MACRO-T|)))
(cond ((and x (alphalessp x '/82))
(push y /#-MACRO-DATALIST))
('T (if (null (setq x (assoc READTABLE /#-MACRO-DATALIST)))
(push (setq x `(,READTABLE . () )) /#-MACRO-DATALIST))
(push y (cdr x)))))
(defun PTR-TYPEP (x)
(cond ((null x) 'CONSTANT)
((not (hunkp x))
(if (eq (setq x (typep x)) 'LIST)
'PAIR
x))
((extendp x)
;;Note how this implies that extends must be hunks
(let ((type (type-of x)))
(if (or (memq type '(VECTOR STRING BITS CHARACTER CONSTANT))
(memq type '#.(mapcan '(lambda (x)
(cond ((memq x '(VECTOR STRING BITS CHARACTER CONSTANT)) () )
((list x))))
;;this var loaded by EXTMAC
*:vax-primitive-types)))
type
'EXTEND)))
('T 'HUNK)))
(declare (own-symbol EQ-FOR-EQUAL?))
(defvar TARGET-FEATURES 'LOCAL
"So it won't be unbound, nor NIL.")
(defun EQ-FOR-EQUAL? (x &aux (type (typep x)))
(cond ((eq type 'SYMBOL) *:TRUTH)
((memq type '(LIST FLONUM BIGNUM)) () )
((and (eq type 'FIXNUM)
(not (eq TARGET-FEATURES 'NIL)))
;;FIXNUM type is not 'eq-for-equal?' in MacLISP, due to Pdlnums,
;; but watch out for cross-compilation!!
() )
((memq (type-of x) '(SYMBOL CONSTANT CHARACTER SMALL-FLONUM))
*:TRUTH)))
;;;; SI:DEFCLASS*-1 (must be in early, for use by later mungeables)
;;; Some old dumps may have a losing SI:DEFCLASS*-2
(eval-when (eval compile load)
(if (equal (args 'SI:DEFCLASS*-2) '(4 . 5))
(args 'SI:DEFCLASS*-2 '(4 . 511.)))
)
(defun SI:DEFCLASS*-1 (typep class-var supr &optional (class-name typep)
source-file &aux class)
(if (cond
((null (setq class (get class-name 'CLASS))))
('T ;;Be sure it's complete
(cond (SI:SKELETAL-CLASSES
(mapc #'SI:INITIALIZE-CLASS SI:SKELETAL-CLASSES)
(setq SI:SKELETAL-CLASSES () )))
(format
MSGFILES
"~&;Re-defining class ~S ~:[~;(previously from file ~1G~A)~]~@
~:[~;(in file ~2G~A)~]"
class-name (get (si:class-plist class) ':SOURCE-FILE) source-file)
(y-or-n-p "~&;Overwrite the existing class?")))
(setq class (si:defclass*-2 class-name
typep
class-var
supr
source-file
class)))
class)
;; SI:INITIALIZE-CLASS sets the slots in the class object that require that
;; EXTEND have been loaded.
(defun SI:INITIALIZE-CLASS (class)
(setf (si:class-SENDI-sym class) 'SI:DEFAULT-SENDI)
(setf (si:class-sendi class) (get 'SI:DEFAULT-SENDI 'SENDI))
(setf (si:class-CALLI-sym class) 'SI:DEFAULT-CALLI)
(setf (si:class-calli class) (get 'SI:DEFAULT-CALLI 'CALLI))
(setf (si:class-map-methods-sym class) 'SI:STANDARD-MAP-OVER-METHODS)
(setf (si:class-map-methods-i class)
(get 'SI:STANDARD-MAP-OVER-METHODS 'MAP-METHODS))
(setf (si:class-map-classes-sym class) 'SI:STANDARD-MAP-OVER-CLASSES)
(setf (si:class-map-classes-i class)
(get 'SI:STANDARD-MAP-OVER-CLASSES 'MAP-CLASSES))
(setf (si:class-add-method-fun class) 'SI:DEFAULT-ADD-METHOD)
()
)
;;;; Create top of CLASS hierarchy
;The class heirarchy has this as its main structure. In actuality, it
;is more complex and classes can have more than one superior.
; (OBJECT CLASS
; (SEQUENCE STRING (VECTOR HEAP-VECTOR STACK-VECTOR)
; BITS (LIST PAIR NULL))
; (NUMBER (INTEGER FIXNUM (BIGNUM POSITIVE-BIGNUM NEGATIVE-BIGNUM))
; (FLOAT FLONUM SMALL-FLONUM BIGFLOAT)
; COMPLEX)
; SUBR CHARACTER SYMBOL (CONSTANT NULL)
; FROBS-OF-YOUR-CHOICE-HERE-AND-BELOW)
;; Now initialize the skeletal classes, (including OBJECT-CLASS)
(mapc #'(lambda (class)
(setf (si:extend-class-of (car class)) CLASS-CLASS)
(setf (si:class-superiors (car class)) (cadr class))
(si:initialize-class (car class))
(if (boundp 'PURCOPY) ;Speed up PURCOPY
(setq PURCOPY (delq (car class) PURCOPY))))
SI:SKELETAL-CLASSES)
(setq SI:SKELETAL-CLASSES () )
#.(if (filep infile)
`(PROGN (SETF (GET (SI:CLASS-PLIST CLASS-CLASS) ':SOURCE-FILE)
',(namestring (truename infile)))
(SETF (GET (SI:CLASS-PLIST OBJECT-CLASS) ':SOURCE-FILE)
',(namestring (truename infile)))))
;;;; Setup SI:INITIAL-CLASSES
(defmacro GEN-DEFCLASSES (x)
`(PROGN 'COMPILE
,.(mapcar
'(lambda (x)
(let (((name supr . options) x) class-var)
(setq supr (cond ((atom supr)
(symbolconc supr '/-CLASS))
((mapcar '(lambda (x)
(symbolconc x '/-CLASS))
supr))))
(setq class-var (symbolconc name '/-CLASS))
`(DEFCLASS* ,name ,class-var ,supr ,. options)))
(eval x))))
(eval-when (eval load compile)
(SETQ SI:INITIAL-CLASSES '((NUMBER OBJECT)
(FLOAT NUMBER)
(INTEGER NUMBER)
(MACLISP-PRIMITIVE OBJECT)
(LIST SEQUENCE)
(PAIR (LIST MACLISP-PRIMITIVE))
(CONSTANT OBJECT)
(NULL ( CONSTANT
LIST
MACLISP-PRIMITIVE)
TYPEP CONSTANT) ;; Boo! Hiss!
(SYMBOL MACLISP-PRIMITIVE)
(FIXNUM (INTEGER MACLISP-PRIMITIVE))
(FLONUM (FLOAT MACLISP-PRIMITIVE))
(RANDOM MACLISP-PRIMITIVE)
(ARRAY MACLISP-PRIMITIVE)
(SFA MACLISP-PRIMITIVE)
(FILE MACLISP-PRIMITIVE)
(JOB MACLISP-PRIMITIVE)
(BIGNUM (INTEGER MACLISP-PRIMITIVE))
(HUNK MACLISP-PRIMITIVE) ))
)
(GEN-DEFCLASSES SI:INITIAL-CLASSES)
(SETQ SI:INITIAL-CLASSES `((OBJECT ())
(CLASS OBJECT)
(STRUCT OBJECT)
(SEQUENCE OBJECT)
,.si:initial-classes))
(setf (si:class-sendi-sym sfa-class) 'SI:SFA-SENDI)
(setf (si:class-sendi sfa-class) (get 'SI:SFA-SENDI 'SENDI))
(def-or-autoloadable GENTEMP MACAID)
(defun LEXPR-SEND (&rest argl)
;; By analogy to LEXPR-FUNCALL, invoke a method with a &REST list of extra
;; arguments.
(lexpr-funcall #'lexpr-funcall #'send argl))
(defun LEXPR-SEND-AS (&rest argl)
;; By analogy to LEXPR-FUNCALL, invoke a method with a &REST list of extra
;; arguments.
(lexpr-funcall #'lexpr-funcall #'send-as argl))
;;;; ADD-METHOD, and special methods for class CLASS
(defun ADD-METHOD (message-key method-fun class)
;; Add a method to a class
(cond ((and *RSET (fboundp 'SI:CHECK-TYPER))
(check-type message-key #'SYMBOLP 'ADD-METHOD)
(check-type class #'CLASSP 'ADD-METHOD)))
(funcall (SI:class-add-method-fun class) message-key method-fun class))
(defun SI:default-add-method (msg-key method-fun class)
(declare (special error-output))
(let ((temp (or (memq msg-key (si:class-methods class))
(setf (si:class-methods class) ;SETF being used for value!
(make-a-method KEY msg-key
NEXT (si:class-methods class)))))
(prop (and (symbolp method-fun)
(getl method-fun '(lsubr expr subr)))))
(setf (method-fun-sym temp) method-fun)
(cond
((symbolp method-fun)
(if (cond ((null prop)
(format error-output
"~&;Warning: Function ~S not yet defined~%"
method-fun)
'T)
((eq (car prop) 'SUBR)
(format error-output
"~&;Warning: Function ~S was compiled as a SUBR~%"
method-fun)
'T))
(format error-output
";Discovered adding method ~S to class ~S.~@
;Method calls will remain interpreted.~%"
msg-key
class))))
(setf (method-fun temp) (if (eq (car prop) 'LSUBR) (cadr prop))))
method-fun)
(defmethod* (:PRINT-SELF CLASS-CLASS) (obj stream () () )
(si:print-extend obj (si:class-name-careful obj) stream))
(defmethod* (FLATSIZE CLASS-CLASS) (obj printp () () )
(si:flatsize-extend obj (si:class-typep obj) printp))
(defmethod* (PURCOPY CLASS-CLASS) (self)
;; Don't copy class objects at all; Pray to heaven that it doesn't go away.
self)
;;Try hard to recreate the class when the file is loaded.
;;Note that CLASS-CLASS, OBJECT-CLASS, STRUCT-CLASS and certain other
;; classes will be present when SI:DEFCLASS*-2 can be done, so we don't
;; try to create those.
(defmethod* (USERATOMS-HOOK CLASS-CLASS) (obj)
(let* ((name (si:class-name-careful obj))
(getter `(GET ',name 'CLASS)))
(list (if (memq name '#.si:extstr-setup-classes)
getter
`(OR ,getter
(AND (GET 'EXTSTR 'VERSION)
(SI:DEFCLASS*-2
',name
',(si:class-typep obj)
',(si:class-var obj)
',(si:class-superiors obj)
',(get (si:class-plist obj) ':SOURCE-FILE))))))))
;;;; Methods for class OBJECT
(DEFMETHOD* (EQUAL OBJECT-CLASS) (OBJ OTHER-OBJ)
(IF (EXTENDP OBJ)
(EQ OBJ OTHER-OBJ)
(EQUAL OBJ OTHER-OBJ)))
;; needed by both DEFVST and STRING.
(defmethod* (PURCOPY object-class) (obj)
(without-interrupts
(let ((class (class-of obj)) (new-obj))
(setf (si:extend-class-of obj) ())
(setq new-obj (purcopy obj))
(setf (si:extend-class-of obj) class)
(setf (si:extend-class-of new-obj) class)
new-obj)))
(DEFMETHOD* (SUBST OBJECT-CLASS) (OBJ () ()) OBJ)
(DEFMETHOD* (SPRINT OBJECT-CLASS) (OBJ () ())
; (DECLARE (SPECIAL L N M))
(PRINT-OBJECT OBJ 0. 'T (SI:NORMALIZE-STREAM OUTFILES)))
(DEFMETHOD* (GFLATSIZE OBJECT-CLASS) (OBJ)
(FLATSIZE-OBJECT OBJ () 0. 'T ))
(DEFMETHOD* (SXHASH OBJECT-CLASS) (OBJ)
(SI:HASH-Q-EXTEND
OBJ
(SXHASH (SI:CLASS-NAME-CAREFUL (SI:EXTEND-CLASS-OF OBJ)))))
(DEFUN SI:HASH-Q-EXTEND (OB ACCUMULATION)
(DECLARE (FIXNUM ACCUMULATION I))
(DO I (1- (EXTEND-LENGTH OB)) (1- I) (< I 0)
(SETQ ACCUMULATION (+ (ROT (SXHASH (SI:XREF OB I)) 11.)
(ROT ACCUMULATION 7))))
ACCUMULATION)
(DEFMETHOD* (USERATOMS-HOOK OBJECT-CLASS) (()) () )
(DEFUN SI:PRINT-EXTEND (OBJ NAME STREAM)
(SI:PRINT-EXTEND-1 OBJ NAME 'T STREAM))
(DEFUN SI:PRINT-EXTEND-MAKNUM (OBJ STREAM &AUX (BASE 8.))
(SI:PRINT-EXTEND-1 OBJ () () STREAM))
(DEFUN SI:PRINT-EXTEND-1 (OBJ NAME NAMEP STREAM)
(SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
(PRINC '|#{| STREAM)
(PRIN1 (SI:CLASS-NAME-CAREFUL (CLASS-OF OBJ)) STREAM)
(TYO #\SPACE STREAM)
(COND (NAMEP (PRIN1 NAME STREAM))
('T (PRINC (MAKNUM OBJ) STREAM)))
(TYO #/} STREAM))
(DEFUN SI:NORMALIZE-STREAM (STREAM)
(IF (AND STREAM
(AND ^R (NULL ^W))
(PAIRP STREAM)
(NOT (MEMQ 'T STREAM))
(NOT (MEMQ TYO STREAM)))
(CONS 'T STREAM)
STREAM))
(DEFUN SI:FLATSIZE-EXTEND (OBJ NAME PRINTP)
(+ (FLATSIZE (SI:CLASS-TYPEP (CLASS-OF OBJ)))
(COND (PRINTP 2)
('T (+ (FLATSIZE NAME) 4)))))
(DEFMETHOD* (PRINT OBJECT-CLASS) (OBJECT &REST ARGL)
(LEXPR-SEND OBJECT ':PRINT-SELF ARGL))
(DEFMETHOD* (:PRINT-SELF OBJECT-CLASS) (OBJ STREAM DEPTH SLASHIFYP)
(COND ((EXTENDP OBJ)
(SI:PRINT-EXTEND-MAKNUM OBJ STREAM))
('T (PRINT-OBJECT OBJ DEPTH SLASHIFYP (SI:NORMALIZE-STREAM STREAM)))))
(DEFMETHOD* (EVAL OBJECT-CLASS) (OBJ) OBJ) ;self-evaluation defaults!
;;;; FIND-METHOD and WHICH-OPERATIONS method
(defun FIND-METHOD (m class)
;; Return the function that gets run for a method-key in specified class
(declare (special m))
(si:map-over-methods
#'(lambda (() method fun)
(declare (special m))
(if (eq method m) fun))
class))
(DEFPROP SI:FIND-METHOD FIND-METHOD EXPR) ;; Foo! 11/7/80 - Jonl
(defun SI:WHERE-IS-METHOD (m class)
;; Return the class in which method "m" is found for class "class"
(declare (special m))
(si:map-over-methods
#'(lambda (class1 method ())
(declare (special m))
(if (eq method m) class1))
class))
(defun SI:OPERATIONS-LIST (class)
;; Collect a list of 'operations'
(let (l)
(declare (special l))
(si:map-over-methods
#'(lambda (class1 meth fun)
(declare (special l))
(push `(,meth ,fun ,class1) l)
() )
class)
(nreverse l)))
(defmethod* (WHICH-OPERATIONS object-class) (object)
;;Collect a list of methods
(let (l)
(declare (special l))
(mapc #'(lambda (meth)
(declare (special l))
(if (not (memq (car meth) l))
(push (car meth) l)))
(si:operations-list (class-of object)))
l))
(defun SI:HAS-SUPERIOR (object class)
;; Returns T iff "object" is in a class which has "class" as superior
(declare (special class))
(si:map-over-classes
#'(lambda (class1 ())
(declare (special class))
(eq class1 class))
object))
;;;; FLATSIZE, EXPLODE methods
(defvar SI:ACCUMULATION ()
"Used to collect the results of the FLATSIZE-HANDLER, or EXPLODE-HANDLER.")
;; Default FLATSIZE method for objects is to just print the object to
;; an counting stream which counts the size in a special variable.
;; A special variable is used since that's easier than consing up a new
;; stream whenever entered recursively.
(defvar SI:FLAT-PRINT-P ()
"If non-(), then the FLATSIZE method wants to throw out on the first space.")
(defmacro CONS-A-FLAT-STREAM ()
`(SFA-CREATE 'SI:FLAT-HANDLER 0 'SI:FLAT-HANDLER))
(defun SI:FLAT-HANDLER (() operation character)
(caseq operation
(TYO (cond ((not (< character 0))
(if (and SI:FLAT-PRINT-P (= character #\SPACE))
(*throw 'SI:FLAT SI:ACCUMULATION))
(setq SI:ACCUMULATION (1+ SI:ACCUMULATION))
T)))
(WHICH-OPERATIONS '(TYO))))
(defvar SI:FLAT-STREAM (cons-a-FLAT-STREAM))
(defmethod* (FLATSIZE object-class) (object printp depth slashifyp)
(let ((SI:ACCUMULATION 0)
(SI:FLAT-PRINT-P printp))
(*catch 'SI:FLAT
(send object ':PRINT-SELF SI:FLAT-STREAM depth slashifyp))
SI:ACCUMULATION))
;; Default EXPLODE method for objects is to just print the object to
;; an accumulation stream which accumulates the list of characters in a
;; special variable. A special variable is used since that's easier
;; than consing up a new stream whenever entered recursively.
;; Whether numbers or single character atoms are to be accumulated is
;; controlled by the special variable SI:EXPLODE-NUMBER-P
(defvar SI:EXPLODE-NUMBER-P ()
"If non-(), then EXPLODEN type method rather than EXPLODEC type.")
(defmacro CONS-A-EXPLODE-STREAM ()
`(SFA-CREATE 'SI:EXPLODE-HANDLER 0 'SI:EXPLODE-HANDLER))
(defun SI:EXPLODE-HANDLER (() operation character)
(caseq operation
(TYO (cond ((< character 0)
(if (not SI:EXPLODE-NUMBER-P)
(setq character (ascii character)))
(push character SI:ACCUMULATION)
T)))
(WHICH-OPERATIONS '(TYO))))
(defvar SI:EXPLODE-STREAM (cons-a-EXPLODE-STREAM))
(defmethod* (EXPLODE object-class) (object slashify-p si:explode-number-p)
(let ((SI:ACCUMULATION)) ;Initialize list to ()
(send object ':PRINT-SELF SI:EXPLODE-STREAM -1 slashify-p)
(nreverse SI:ACCUMULATION)))
;;;; GRINDEF, HUNKSPRIN1, and USERATOMS hooks -- and some setups
(defun SI:EXTEND-HUNKSPRIN1 (obj n m)
; (declare (special l n m))
(cond ((extendp obj) (send obj 'SPRINT n m))
(T (standard-hunksprin1 obj n m))))
(defun SI:EXTEND-GFLATSIZE (obj)
(declare (special l n m))
(cond ((extendp obj) (send obj 'GFLATSIZE))
('T (funcall (get 'STANDARD-HUNKSPRIN1 'HUNKGFLATSIZE) obj ;n m
))))
(setq HUNKSPRIN1 'SI:EXTEND-HUNKSPRIN1)
(defprop SI:EXTEND-HUNKSPRIN1 SI:EXTEND-GFLATSIZE HUNKGFLATSIZE)
;; Activate the message-passing interpreter
(sstatus SENDI 'SEND)
(sstatus USRHUNK 'EXTENDP)
(sstatus CALLI 'SI:CALLI-TRANSFER)
(def-or-autoloadable SI:LOST-MESSAGE-HANDLER CERROR)
(let ((x (status LISPV)))
(cond
((alphalessp x "2094")
;;Just in case someone tries to use this in a really old lisp!
(if (alphalessp x "2057")
(mapc
#'(lambda (z)
(let ((y (subst (car z) 'Z #%(AUTOLOAD-FILENAME Z))))
(mapc #'(lambda (x)
(or (fboundp x)
(equal (get x AUTOLOAD) y)
(putprop x y 'AUTOLOAD)))
(cadr z))))
'( (MLMAC (PAIRP))
(EXTMAC (DEFCLASS* DEFMETHOD*))
(CERROR (CERROR FERROR ))
(ERRCK (CHECK-TYPE SI:CHECK-TYPER CHECK-SUBSEQUENCE
SI:CHECK-SUBSEQUENCER))
(SUBSEQ (TO-LIST TO-VECTOR TO-STRING TO-BITS SUBSEQ REPLACE))
(YESNOP (Y-OR-N-P YES-OR-NO-P)))))
;;WOW! What a kludge! In old LISP's we somehow have to force in
;; the DESCRIBE file (since, who knows, we may be autoloading just
;; in order to get the DESCRIBE function.) And DESCRIBE, of course,
;; tries to force-load in the EXTEND file. Circularity. Q.E.D.
(or (get 'EXTEND 'VERSION) (defprop EXTEND /0 VERSION))
#%(subload DESCRIBE))))

293
src/lspsrc/extmac.191 Executable file
View File

@@ -0,0 +1,293 @@
;;; EXTMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ****************************************************************
;;; *** MacLISP **** EXTended datatype scheme, MACros **************
;;; ****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;; ****************************************************************
(herald EXTMAC /191)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
)
(eval-when (eval load compile)
(subload MACAID) ;Also down-loads DEFMAX
(subload ERRCK)
)
(eval-when (compile)
(setq DEFMACRO-FOR-COMPILING 'T DEFMACRO-DISPLACE-CALL MACROEXPANDED)
(own-symbol DEFCLASS* DEFMETHOD*)
)
(defvar SI:EXTSTR-SETUP-CLASSES
'(OBJECT-CLASS CLASS-CLASS VECTOR-CLASS STRUCT-CLASS STRUCT=INFO-CLASS SEQUENCE-CLASS)
"This list corresponds to what is set up in EXTSTR")
(defvar SI:EXTEND-Q-OVERHEAD 2
"Number of slots taken out of a hunk for EXTEND overhead.")
(defmacro SI:EXTEND-CLASS-OF (x) `(CXR 0 ,x))
(defmacro SI:EXTEND-MARKER-OF (x) `(CXR 1 ,x))
;;;; Initial CLASS object structure, and DEFCLASS*
;; Leave around for benefit of NILSIM;PACKAGE
(defmacro SI:DEF-INITIAL-EXTEND-STRUCT
(package prefix &rest rest
&aux (count 0)
(sizym (symbolconc package
'/: PREFIX
'-INSTANCE-SIZE))
access-sym)
`(PROGN 'COMPILE
,.(mapcan
#'(lambda (frob)
(if (not (atom frob)) (setq frob (car frob)))
(setq access-sym (symbolconc package '/: prefix '- frob))
;;; Use one function for macro-expanding all accessor macros
`( (DEFPROP ,access-sym
,(prog1 count (setq count (1+ count)))
SI:CLASS-SLOT-ACCESSOR)
(DEFPROP ,access-sym SI:CLASS-SLOT-ACCESSOR MACRO)))
rest)
(DECLARE (SPECIAL ,sizym)) ;|Number of Q's in instances of this class|
(EVAL-WHEN (EVAL LOAD COMPILE) (SETQ ,sizym ,count))))
(SI:DEF-INITIAL-EXTEND-STRUCT SI CLASS
SENDI ;; LSUBR-like function to jump to for SENDs to instances.
SENDI-SYM ;; SYMBOL or LAMBDA the SENDI LSUBR came from
CALLI ;; Similarly, for FUNCALLs.
CALLI-SYM
MAP-METHODS-I ;; Interpreter for MAP-OVER-METHODS
MAP-METHODS-SYM
MAP-CLASSES-I ;; Interpreter for MAP-OVER-CLASSES
MAP-CLASSES-SYM
ADD-METHOD-FUN ;; SUBRCALLed to add a method to a class
TYPEP ;; Symbol returned by TYPEP.
SUPERIORS ;; NCONS of superior class.
NAME ;; Name of this class
METHODS ;; An a-list of (KEY . <function>).
PLIST ;; PLIST of random information
)
(defun SI:CLASS-SLOT-ACCESSOR ((fun val))
(let ((slot (get fun 'SI:CLASS-SLOT-ACCESSOR)))
(if (null slot) (+internal-lossage 'NULL 'SI:CLASS-SLOT-ACCESSOR fun))
(if (memq compiler-state '(COMPILE MAKLAP))
`(SI:XREF ,val ,slot)
`(SI:XREF
(LET ((VAL ,val))
;;When EXTMAC is loaded, so will be ERRCK and SENDI
;;If this macro writes out expr code to a file, rather
;; than having it compiled, then the loser will just have
;; to run such expr code in a lisp with ERRCK and SENDI
(IF *RSET (CHECK-TYPE VAL #'CLASSP ',fun))
VAL)
,slot))))
(defmacro SI:CLASS-ATTRIBUTES (class)
`(si:class-plist ,class))
(defmacro SI:CLASS-VAR (class)
`(get (si:class-plist ,class) ':VARIABLE))
(defmacro SI:CLASS-DOCUMENTATION (class)
`(get (si:class-plist ,class) ':DOCUMENTATION))
;;Someday this should just turn into SI:CLASS-NAME -- when all those old
;; classes composed out of HUNK16's go away. July 4, 1981 - JonL -
(defmacro SI:CLASS-NAME-CAREFUL (class)
`(let ((class ,class))
(if (eq (typep class) 'HUNK32)
(SI:XREF CLASS 16.)
(si:class-name class))))
;; (DEFCLASS* name variable superior . options)
;; creates a new CLASS object, assigning it to the variable
;; VARIABLE.
(defmacro DEFCLASS* (name var supr &rest options &aux (typep name))
(and supr (symbolp supr) (setq supr (list supr)))
(do ((l options (cddr L)))
((null l))
(caseq (car l)
(TYPEP (setq typep (cadr l)))
(T (error "unknown option - DEFCLASS*"
(list (car l) (cadr l))))))
`(PROGN 'COMPILE
,@(if var `((DEFVAR ,var)))
(SI:DEFCLASS*-1 ',typep
',var
(LIST ,@supr)
',name
,@(if (filep infile)
(list `',(namestring (truename infile)))))))
;;;; DEFMETHOD*, and MAKE-A-METHOD
;; (DEFMETHOD* (KEY FOO-CLASS) (FROB . ARGS) . BODY)
;; defines a KEY method for instances of class FOO.
;; When someone does a (SEND BAR 'KEY ARG1 ARG2), FROB is bound to
;; BAR, the ARGS are bound to ARG1 and ARG2, and the BODY is run.
;; KEY can be a list of keys instead of a single key
(defmacro DEFMETHOD* ((msg-key class-var) (obj . arglist) &rest body)
(let* ((keys (if (atom msg-key) (ncons msg-key)
msg-key))
(method-fun (symbolconc (car keys) '-> class-var)))
`(PROGN 'COMPILE
(DECLARE (**LEXPR ,method-fun))
(DEFUN ,method-fun (,obj () ,.arglist) ,.body)
,.(mapcar #'(lambda (key)
`(ADD-METHOD ',key ',method-fun ,class-var))
keys))))
(defmacro MAKE-A-METHOD (&rest keywords &aux
(keyplist (cons 'keyplist keywords)))
(let ((key (get keyplist 'key))
(fun (get keyplist 'fun))
(next (get keyplist 'next)))
`(hunk ,key (and (symbolp ,fun)
(get ,fun 'lsubr))
,fun ,next)))
;;;; TYPECASEQ
;; Temporary definition for ERROR-OUTPUT, unless CERROR is loaded
(defvar ERROR-OUTPUT 'T)
(defvar *:TRUTH 'T)
(defvar *:VAX-PRIMITIVE-TYPES
'(PAIR SYMBOL FIXNUM FLONUM
VECTOR STRING BITS CHARACTER CONSTANT EXTEND
VECTOR-S SUBR MSUBR FLONUM-S SMALL-FLONUM))
;; This definition of TYPECASEQ warns of LIST instead of PAIR, and
;; also of use of the extended TYPECASEQ syntax. It also warns of
;; the use of T to denote an OTHERWISE clause, iff running in NIL.
(defmacro TYPECASEQ (typ &rest clauses)
(setq clauses
(mapcar ;Clobber LIST to PAIR, an warn of EXTENDs
#'(lambda (clause)
(setq clause (append clause ()))
(if (and (status feature NIL)
(not (eq *:TRUTH 'T))
(eq (car clause) *:TRUTH))
(rplaca clause 'T)) ;Fix loser's code. ######## Dangerous!!!
(if (eq (car clause) 'T)
clause
(let ((types (if (atom (car clause))
(ncons (car clause))
(append (car clause) ()))))
(map #'(lambda (types) ;Side effect if LIST
(cond
((eq (car types) 'LIST)
(format
error-output
"~&;Warning: LIST keyword in TYPECASEQ clause -- ~
Converting to PAIR~%")
(rplaca types 'PAIR)))
(cond
((not (memq (car types) *:VAX-primitive-types))
(format
error-output
"~&;Warning: ~S non-primitive type in TYPECASEQ~%"
(car types)))))
types)
(rplaca clause types))))
clauses))
`(CASEQ (PTR-TYPEP ,typ)
,.clauses))
;; So a "method" is just a 4-hunk
(defmacro METHOD-NEXT (x) `(CXR 0 ,x))
(defmacro METHOD-SYMBOL (x) `(CXR 1 ,x))
(defmacro METHOD-FUN (x) `(CXR 2 ,x))
(defmacro METHOD-FUN-SYM (x) `(CXR 3 ,x))
;;;; DEFSFA
(defmacro DEFSFA (name (sfa operation) vars options &rest ops)
(let ((constructor-name (symbolconc 'cons-a- name))
(handler-name (symbolconc name '-sfa-handler))
(wops (nconc (delq ':SEND (mapcar #'CAR ops)) '(:SEND)))
(data (si:gen-local-var () "SFA-DATA"))
(idx -1)
(initter (memq ':INIT options))
accessor )
(declare (fixnum idx))
`(PROGN 'COMPILE
(EVAL-WHEN (EVAL LOAD COMPILE)
(DECLARE (SPECIAL MACLISP-PRIMITIVE-CLASS))
(def-or-autoloadable SEND-AS EXTEND)
(def-or-autoloadable SFA-UNCLAIMED-MESSAGE EXTSFA)
(def-or-autoloadable SI:DEFSFA-ACCESSOR EXTSFA)
(def-or-autoloadable SI:DEFSFA-CREATOR EXTSFA)
(def-or-autoloadable SI:INIT-SFA EXTSFA)
(DEFPROP ,constructor-name SI:DEFSFA-CREATOR MACRO)
(DEFPROP ,constructor-name ,name DEFSFA-NAME)
,(if initter
`(PUTPROP ',name
,(cadr initter)
'DEFSFA-INITP)
`(DEFPROP ,name T DEFSFA-INITP))
(DEFPROP ,name ,(length vars) DEFSFA-SIZE)
(DEFPROP ,name ,handler-name DEFSFA-HANDLER)
(DEFPROP ,name ,vars DEFSFA-INITS)
,.(mapcan #'(lambda (var)
(if (pairp var) (setq var (car var)))
(setq accessor (symbolconc name '- var)
idx (1+ idx))
`( (DEFPROP ,accessor ,idx DEFSFA-IDX)
(DEFPROP ,accessor SI:DEFSFA-ACCESSOR MACRO)))
vars))
(DEFUN ,handler-name (,sfa ,operation ,data)
(CASEQ ,operation
,@(mapcan #'(lambda (clause)
(if (atom (cadr clause))
`((,(car clause)
(LET ((,(cadr clause) ,data))
,@(cddr clause))))))
ops)
(:SEND (DESETQ (,operation ,data) ,data)
(CASEQ ,operation
,@(mapcan #'(lambda (clause)
(if (not (atom (cadr clause)))
`((,(car clause)
(LET ((,(cadr clause) ,data))
,@(cddr clause))))))
ops)
(T (SFA-CALL ,sfa ,operation ,data))))
(WHICH-OPERATIONS
(IF (FBOUNDP 'SEND-AS)
(APPEND ',wops
(DELETE 'PRINT ;Temporary, has :PRINT-SELF meaning too
(SEND-AS MACLISP-PRIMITIVE-CLASS
,sfa
'WHICH-OPERATIONS)))
',wops))
(SI:WHICH-OPERATIONS-INTERNAL ',wops)
(:INIT (SI:INIT-SFA ,sfa ',name ,data))
(T (SFA-UNCLAIMED-MESSAGE ,sfa ,operation ,data)))))))
(def-or-autoloadable SI:DEFSFA-CREATOR EXTSFA)
(def-or-autoloadable SI:DEFSFA-ACCESSOR EXTSFA)

138
src/lspsrc/extsfa.8 Executable file
View File

@@ -0,0 +1,138 @@
;;; EXTSFA -*-LISP-*-
;;; ***************************************************************
;;; *** MACLISP ********** EXTEND/SFA Interface *******************
;;; ***************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ***
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES REVERSED) ********
;;; ***************************************************************
(herald EXTSFA /8)
(include ((lisp) subload lsp))
(eval-when (eval compile)
(subload UMLMAC)
)
(declare (special MACLISP-PRIMITIVE-CLASS)
(defprop SFA-UNCLAIMED-MESSAGE T SKIP-WARNING))
;; Call this routine to handle an SFA not understanding the message it was
;; sent. It will send back the apropriate message if the message was the
;; result of a SEND. It will interface to the CLASS heirarchy to find methods
;; in superclasses, if SEND-AS is defined. WHICH-OPERATIONS is hacked to
;; do the right thing where possible, when (SEND sfa 'WHICH-OPERATIONS) is
;; done. And if nothing else works, an error is reported.
(defun SFA-UNCLAIMED-MESSAGE (sfa operation data)
(caseq operation
(:SEND
(desetq (operation . data) data)
(cond ((memq operation (sfa-call sfa 'si:which-operations-internal ()))
(sfa-call sfa operation (car data)))
;; Catch (SEND sfa 'WHICH-OPERATIONS) and extract the info
((eq operation 'which-operations)
(if (fboundp 'send-as)
(append (sfa-call sfa operation ())
(delete 'PRINT ;Old meaning is :PRINT-SELF
(send-as MACLISP-PRIMITIVE-CLASS sfa
'WHICH-OPERATIONS)))
(sfa-call sfa operation () )))
('T (si:sfa-unclaimed-message-1 sfa operation data))))
(SI:WHICH-OPERATIONS-INTERNAL ;Provide a default in case hand-coded
(sfa-call sfa 'WHICH-OPERATIONS () ))
(T (si:sfa-unclaimed-message-1 sfa operation (ncons data)))))
;; A helper for the above. Invoke superior if we have the class heirarchy,
;; else, report an error.
(defun SI:SFA-UNCLAIMED-MESSAGE-1 (sfa operation data)
(if (fboundp 'send-as) (lexpr-send-as maclisp-primitive-class
sfa operation data)
(ferror ':UNCLAIMED-MESSAGE
"The message ~S went unclaimed by ~S. Args: ~S"
operation sfa data)))
;; Worker for CONS-A-mumble constructors for SFA's. Lives on the MACRO
;; property. Returns the apropriate code. Gets the name of the SFA from the
;; PLIST of the macro name, and gets the rest of the info from that symbol.
(defun SI:DEFSFA-CREATOR ((creator . argl))
(let* ((name (get creator 'defsfa-name)) ;Name of SFA
(argl (cons name argl)) ;PLIST so GET will work
(handler (get name 'defsfa-handler)) ;Functional handler
(initp (get name 'defsfa-initp)) ;Whether to do :INIT
(size (get name 'defsfa-size)) ;# of slots to allocate
(sfa-name (or (get argl ':PNAME) ;How to print it
`(GENTEMP ',name))))
(remprop argl ':PNAME) ;Hacked here, not in SI:DEFSFA-INITS
(if (or initp argl)
(let ((temp (si:gen-local-var () "NEW-SFA")))
`(LET ((,temp (SFA-CREATE ',handler ,size ,sfa-name)))
(SFA-CALL ,temp ':INIT (LIST ,@(si:defsfa-inits name (cdr argl))))
,temp))
`(SFA-CREATE ',handler ,size ,sfa-name))))
;; Take each init spec, and add in the defaults, and return a list of
;; alternating quoted keywords and forms to EVAL for values.
(defun SI:DEFSFA-INITS (name argl &aux initl
(name-inits (get name 'defsfa-inits)))
(do ((ll argl (cddr ll))
(res () `(,(cadr ll) ',(car ll) ,. res)))
((null ll) (setq initl res))
(if (or (memq (car ll) name-inits) (assq (car ll) name-inits))
(setq name-inits (si:defsfa-remassq (car ll) name-inits))))
(do ((ll name-inits (cdr ll)))
((null ll) (setq initl (nreverse initl)))
(when (pairp (car ll))
(push `',(caar ll) initl)
(push (cadr (car ll)) initl)))
initl)
;; Flush all A's and (A ...)'s in '(A ... (A ...) ..)
;; I.e. remove all defaulted or undefaulted references to the slot A from
;; the list.
(defun SI:DEFSFA-REMASSQ (item list)
(if list
(if (or (eq item (car list))
(and (not (atom (car list)))
(eq item (caar list))))
(si:defsfa-remassq item (cdr list))
(cons (car list)
(si:defsfa-remassq item (cdr list))))))
;; Return the code for accessing the slot, given a macro-call.
;; Lives on the MACRO property of accessors
(defun SI:DEFSFA-ACCESSOR ((name sfa))
`(sfa-get ,sfa ,(get name 'defsfa-idx)))
;; Store the initializations given a list of keywords and values to store
;; there. DOES NOT EVAL.
(defun SI:INIT-SFA (sfa name data)
(setq data (cons name data))
(do ((ll (get name 'defsfa-inits) (cdr ll))
(idx 0 (1+ idx))
(item))
((null ll) sfa)
(if (atom (car ll))
(setq item (get data (car ll)))
(setq item (get data (caar ll))))
(sfa-store sfa idx item)))
(def-or-autoloadable GENTEMP MACAID)
(def-or-autoloadable SI:GEN-LOCAL-VAR MACAID)
(def-or-autoloadable SEND-AS EXTEND)
(def-or-autoloadable LEXPR-SEND EXTEND)
(def-or-autoloadable LEXPR-SEND-AS EXTEND)

174
src/lspsrc/extstr.97 Normal file
View File

@@ -0,0 +1,174 @@
;;; EXTSTR -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ****************************************************************
;;; *** MACLISP **** EXTended datatype scheme, basic STRuctures ****
;;; ****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ****
;;; ****************************************************************
(herald EXTSTR /97)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload EXTBAS)
(subload EXTMAC)
(subload EXTEND)
;; This would like to be a SUBLOAD of VECTOR, but this way it's not circular
(defmacro VSET (v n val) `(SI:XSET ,v ,n ,val))
)
;;; Wherein we build HUNKs for each class that will be directly pointed to
;;; by classes defined by DEFVST. We leave out the interconnections between
;;; classes, to help printing of objects defined by DEFVST. Loading EXTEND
;;; will supply the missing interconnections.
;;; We also define the basic CLASS creator, SI:DEFCLASS*-2 a sub-primitive that
;;; gives a skeletal class. This class can then be filled in by calling
;;; SI:INITIALIZE-CLASS (from EXTEND)
(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps")
;;; SI:EXTSTR-SETUP-CLASSES is set up by EXTMAC, and includes things
;;; like CLASS-CLASS OBJECT-CLASS STRUCT=INFO-CLASS STRUCT-CLASS VECTOR-CLASS
(declare #.`(SPECIAL ,.si:extstr-setup-classes))
(setq-if-unbound CLASS-CLASS () "Will be set up, at some pain, in this file")
(setq-if-unbound OBJECT-CLASS () "Will be set up, at some pain, in this file")
(declare (own-symbol **SELF-EVAL** SI:DEFCLASS*-2 SI:DEFVST-BARE-INIT))
(defun SI:SELF-QUOTIFY (x) `',x)
(eval-when (eval compile load)
;; So that we can easily tell classes apart from random extends
(defvar SI:CLASS-MARKER '**CLASS-SELF-EVAL**)
(and (status feature COMPLR)
(*lexpr SI:DEFCLASS*-2 SI:DEFVST-BARE-INIT))
)
(defprop **SELF-EVAL** SI:SELF-QUOTIFY MACRO)
(defprop #.SI:CLASS-MARKER SI:SELF-QUOTIFY MACRO) ;**CLASS-SELF-EVAL**
;;;; SI:DEFCLASS*-2
(defun SI:DEFCLASS*-2 (name typep var superiors
&optional source-file class
&rest ignore )
(cond ((cond ((null class))
((not (classp class))
(+internal-lossage 'CLASS 'SI:DEFCLASS*-2 class)
'T))
;;Note that at initial boot-strap phase, CLASS-CLASS may not exist,
;; but either function -- si:make-extend or si:make-random-extend --
;; will be open-coded by COMPLR
(setq class (si:make-random-extend #.si:class-instance-size
CLASS-CLASS))
(setf (si:extend-marker-of class) SI:CLASS-MARKER)
(setf (si:class-typep class) typep)
(setf (si:class-plist class) (ncons name))
(setf (si:class-name class) name)))
(if source-file
(setf (get (si:class-plist class) ':SOURCE-FILE) source-file))
(if var
(setf (si:class-var (set var class)) var))
(cond ((fboundp 'SI:INITIALIZE-CLASS)
(setf (si:class-superiors class) superiors)
(si:initialize-class class))
('T (push `(,class ,superiors) SI:SKELETAL-CLASSES)
(setf (si:extend-class-of class) () )
(if (boundp 'PURCOPY) (push class PURCOPY))))
(putprop name class 'CLASS)
class)
;;;Move &OPTIONAL to after VERSION once old files are flushed (after
;;; defvst-version 1 is gone). July 4, 1981 -- JonL --
;;;See also the similar comments in DEFVSY.
(defun SI:DEFVST-BARE-INIT (name var-name cnsn size inis
&optional (version 1) source-file class sinfo
&rest ignore)
(if (pairp inis)
;; a slight open-coding of TO-VECTOR for (SETQ INIS (TO-VECTOR INIS))
(setq inis (let ((ln (length inis)))
(declare (fixnum ln))
(do ((v (si:make-extend ln VECTOR-CLASS))
(i 0 (1+ i))
(l inis (cdr l)))
((= i ln) v)
(declare (fixnum i))
(vset v i (car l))))))
(if (null class)
(setq class (or (get name 'CLASS)
(si:defclass*-2 name
name
var-name
(list STRUCT-CLASS)
source-file))))
(if (null sinfo)
(setq sinfo (si:extend STRUCT=INFO-CLASS
version
name
cnsn
size
inis
class)))
(putprop name sinfo 'STRUCT=INFO)
;;The STRUCT=INFO property can always be found on the plist of the 'name'
;; of the structure (and consequently the 'name' of the class)
;;So I've the following line optional, so that it doesn't cause
;; a printing circularity when EXTEND isn't loaded.
(if (get 'EXTEND 'VERSION)
(setf (get (si:class-plist class) 'STRUCT=INFO) sinfo)))
;; Setup basics of CLASS hierarchy, if not already done so. DEFVAR
;; at beginning of this file ensures that CLASS-CLASS has a value.
(and (null CLASS-CLASS)
(let (y x)
(mapc #'(lambda (z)
(desetq (x y z) z)
(si:defclass*-2 x x y (if z (list (symeval z)))))
'((OBJECT OBJECT-CLASS () )
(CLASS CLASS-CLASS OBJECT-CLASS)
(SEQUENCE SEQUENCE-CLASS OBJECT-CLASS)
(VECTOR VECTOR-CLASS SEQUENCE-CLASS)
(STRUCT STRUCT-CLASS OBJECT-CLASS)
(STRUCT=INFO STRUCT=INFO-CLASS STRUCT-CLASS)))))
;; The following is an open-coding of part of the result of CONS-A-STRUCT=INFO.
(si:defvst-bare-init
'STRUCT=INFO
'STRUCT=INFO-CLASS
'CONS-A-STRUCT=INFO
6
'( () ;&REST info
(VERS STRUCT=INFO-VERS SI:STRUCT=INFO-VERSION ) ;1st key
(NAME STRUCT=INFO-NAME () ) ;2nd
(CNSN STRUCT=INFO-CNSN () ) ;3nd
(SIZE STRUCT=INFO-SIZE 0 ) ;4rd
(INIS STRUCT=INFO-INIS () ) ;5th
(CLSS STRUCT=INFO-CLSS STRUCT=INFO-CLASS) ;6th
)
2) ;Version
(eval-when (eval compile)
(defmacro GEN-SOURCE-FILE-ADDENDA ()
(if (filep infile)
`(MAPC #'(LAMBDA (CLASS)
(SETF (GET (SI:CLASS-PLIST CLASS) ':SOURCE-FILE)
',(namestring (truename infile))))
(LIST CLASS-CLASS OBJECT-CLASS VECTOR-CLASS STRUCT-CLASS
STRUCT=INFO-CLASS SEQUENCE-CLASS))))
)
(gen-source-file-addenda)
(if (status feature COMPLR)
(subload EXTHUK))

335
src/lspsrc/grind.422 Normal file
View File

@@ -0,0 +1,335 @@
;;; -*-LISP-*-
;;; ***********************************************************************
;;; ***** Maclisp ****** S-expression formatter for files (grind) *********
;;; ***********************************************************************
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology ***********
;;; ****** this is a read-only file! (all writes reserved) ****************
;;; ***********************************************************************
;;; This version of Grind works in both ITS Maclisp and Multics Maclisp
;;; GFILE - fns for pretty-printing and grinding files.
(eval-when (eval compile)
(or (status nofeature MACLISP)
(status macro /#)
(load '((LISP) SHARPM)))
)
(herald GRIND /422)
(declare (array* (notype (gtab/| 128.)))
(special merge readtable grindreadtable remsemi ~r
grindpredict grindproperties grindef predict
grindfn grindmacro programspace topwidth
grindlinct global-lincnt /; /;/; user-paging form
prog? n m l h arg chrct linel pagewidth gap comspace
grindfill nomerge comnt /;/;? ^d macro unbnd-vrbl
cnvrgrindflag outfiles infile stringp)
(*expr form topwidth programspace pagewidth comspace
nomerge remsemi stringp)
(*fexpr trace slashify unslashify grindfn grindmacro
unreadmacro readmacro grindef)
(*lexpr merge predict user-paging grindfill testl)
(mapex t)
(genprefix gr+)
(fixnum nn
mm
(grchrct)
(newlinel-set fixnum)
(prog-predict notype fixnum fixnum)
(block-predict notype fixnum fixnum)
(setq-predict notype fixnum fixnum)
(panmax notype fixnum fixnum)
(maxpan notype fixnum fixnum)
(gflatsize)))
(prog () ;some initializations
(and (not (boundp 'grind-use-original-readtable))
(setq grind-use-original-readtable t))
(and (or (not (boundp 'grindreadtable)) ;readtable (default).
(null grindreadtable))
((lambda (readtable) (setsyntax 12. 'single ()) ;^l made noticeable.
(setsyntax '/;
'splicing
'semi-comment))
(setq grindreadtable
(*array ()
'readtable
grind-use-original-readtable))))
(setq macro '/;
/; (copysymbol '/; ())
/;/; (copysymbol '/;/; ()))
(setq grindlinct 8. global-lincnt 59. comnt () /;/;? ())
(setq stringp (status feature string))
)
;;; Grinds and files file.
(defun grind fexpr (file)
((lambda (x)
(cond ((and stringp (stringp (car file)))) ;already filed.
(t (cond ((not (status feature its))
(cond ((status feature DEC20)
(setq x (append (namelist x) () ))
(rplacd (cddr x) () ))
((probef x) (deletef x)))))
(apply 'ufile x)))
file)
(apply 'grind0 file)))
(defun grind0 fexpr (file) ;grinds file and returns file
(or (status feature grindef)
(funcall autoload (cons 'grindef (get 'grindef 'autoload))))
(prog (remsemi linel *nopoint readtable base l ^q ^r ^w ^d
outfiles eof n /;/;? comnt terpri)
(setq base 10. linel programspace
readtable grindreadtable remsemi t)
(cond
((and stringp (stringp (car file)))
(inpush (openi (car file)))
(setq
outfiles
(list
(openo
(mergef
(cond ((null (cdr file))
(princ '|/
Filing as !GRIND OUTPUT |)
'(* /!GRIND OUTPUT))
((cadr file)))
(cons (car (namelist ())) '*) )))))
('t (apply (cond ((status feature sail) 'eread) ('uread))
(cond ((and (null (cdr file)) (symbolp (car file)))
(car file))
((and (status feature sail)
(cadr file)
(eq (cadr file) 'dsk))
(cons (car file) (cons '| | (cdr file))))
('t file)))
(uwrite)))
(setq eof (list ()) n topwidth)
(setq ^q t ^r t ^w t grindlinct global-lincnt)
read (and (= (tyipeek 47791616. -1)
59.) ;catch top-level splicing macro
(readch)
(cond ((eq (car (setq l (car (semi-comment)))) /;)
(rem/;)
(go read))
(t (go read1))))
(and (null ^q) (setq l eof) (go read1)) ;catch eof in tyipeek
(and (eq (car (setq l (read eof))) /;) ;store /; strings of /; comments.
(rem/;)
(go read))
read1(prinallcmnt) ;print stored /; comments
(or (eq eof l) (go process))
exit (terpri)
(setq ~r ())
(and stringp
(stringp (car file))
(close (car outfiles))) ;won't get ufile'd
(return file)
process
(cond ((eq l (ascii 12.)) ;formfeed read in ppage mode
(or user-paging (go read)) ;ignore ^l except in user-paging mode.
(and (< (tyipeek 50167296. -1) 0)
(go exit)) ;any non-trivial characters before eof?
(terpri)
(grindpage)
(setq /;/;? t)
(go read))
((eq (car l) /;/;) ;toplevel ;;... comment
(newlinel-set topwidth)
(or /;/;? (= linel (grchrct)) (turpri) (turpri)) ;produces blank line preceding new
(rem/;/;) ;block of /;/; comments. (turpri is
(newlinel-set programspace) ;already in rem/;/;). a total of 3
(go read))) ;turpri's are necessary if initially
(fillarray 'gtab/| '(())) ;chrct is not linel, ie we have just
(cond (user-paging (turpri) (turpri)) ;finished a line and have not yet cr.
((< (turpri)
(catch (\ (panmax l (grchrct) 0.) 60.))) ;clear hash array
(grindpage))
((turpri)))
(cond ((eq (car l) 'lap) (lap-grind))
((sprint1 l linel 0.) (prin1 l)))
(tyo 32.) ;prevents toplevel atoms from being
(go read))) ;accidentally merged by being separated only by
;cr.
(defun newlinel-set (x)
(setq chrct (+ chrct (- x linel))
linel x))
(putprop /; '(lambda (l n m) 0.) 'grindpredict)
(putprop /;/; '(lambda (l n m) 1.) 'grindpredict)
;;semi-colon comments
(defun rem/; ()
(prog (c retval)
a (cond ((atom l) (return retval))
((eq (car l) /;)
(setq c (cdr l))
(setq retval 'car)
(setq l ()))
((and (null (atom (car l))) (eq (caar l) /;))
(setq c (cdar l))
(setq retval 'caar)
(setq l (cdr l)))
(t (cond ((and (eq retval 'caar) ;look ahead to separate comments.
(cdr l)
(null (atom (cdr l)))
(null (atom (cadr l)))
(eq (caadr l) /;))
(prinallcmnt)
(indent-to n)))
(return retval)))
b (cond ((null comnt) (setq comnt c))
((< comspace (length comnt)) (turpri) (go b))
((nconc comnt (cons '/ c))))
(go a)))
(defun rem/;/; ()
(prog (c retval)
a (cond ((atom l)
(and (eq retval 'caar) (indent-to n))
(return retval))
((eq (car l) /;/;)
(setq c (cdr l))
(setq retval 'car)
(setq l ()))
((and (null (atom (car l))) (eq (caar l) /;/;))
(setq c (cdar l))
(setq retval 'caar)
(setq l (cdr l)))
(t (and (eq retval 'caar) (indent-to n)) ;restore indentation for upcoming code
(return retval)))
(prinallcmnt)
(and (null /;/;?) (turpri))
(prog (comnt pagewidth comspace macro)
(setq comnt c)
(and (or (memq (car c) '(/; *))
(null merge)) ;nomerge. update pagewidth, comspace
(setq /;/;? '/;/;/;) ;appropriate for a total line of
(setq pagewidth topwidth ;topwidth
comspace (+ n (- topwidth linel)))
(go prinall))
(setq pagewidth linel)
(cond ((eq /;/;? /;/;) ;preceding comnt. merge.
(setq comnt (cons '/ comnt))
(setq macro (ascii 0.))
(setq comspace (grchrct))
(prin50com))
((setq /;/;? /;/;)))
(setq comspace n)
prinall
(setq macro /;/;)
(prinallcmnt))
(tj6 c)
(go a)))
(defun tj6 (x) ;tj6 commands: ;;*--- or ;;*(...) (...)
(and
(eq (car x) '*)
(setq x (cdr x))
(turpri)
(cond
((errset
(cond ((atom (car (setq x
(readlist (cons '/(
(nconc x
'(/))))))))
(eval x))
((mapc 'eval x)))))
((error '/;/;*/ error x 11.)))))
(defun prin50com () ;prints one line of ; comment
(prog (next)
(newlinel-set pagewidth) ;update linel, chrct for space of pagewidth.
(prog (comnt) (indent-to comspace))
(princ macro)
pl
(cond ((null comnt) (return ()))
((eq (car comnt) '/ )
(setq comnt (cdr comnt))
(setq next
(do ((x comnt (cdr x)) (num 2. (1+ num))) ;number of characters till next space.
((or (null x) (eq (car x) '/ ))
num)))
(cond ((and (or (eq macro /;) (eq /;/;? /;/;))
grindfill
(= next 2.)
(go pl)))
((and (not (eq macro (ascii 0.)))
(> next comspace)))
((< (grchrct) next) (return ())))
(tyo 32.)
(go pl))
((> (grchrct) 0.)
(princ (car comnt))
(and (or (eq macro /;) (eq /;/;? /;/;))
grindfill
(eq (car comnt) '/.)
(eq (cadr comnt) '/ )
(tyo 32.)))
(t (return ())))
(setq comnt (cdr comnt))
(go pl))
(newlinel-set programspace)) ;may restore chrct to be negative.
(defun prinallcmnt () (cond (comnt (prin50com) (prinallcmnt)))) ;prints \ of ; comment
(defun semi-comment () ;converts ; and ;; comments to exploded
(prog (com last char) ;lists
(setq com (cons /; ()) last com)
(setq char (readch)) ;decide type of semi comment
(cond ((eq char '/
) (return (list com)))
((eq char '/;) (rplaca last /;/;))
((rplacd last (cons char ()))
(setq last (cdr last))))
a (setq char (readch))
(cond ((eq char '/
) (return (list com)))
((rplacd last (cons char ()))
(setq last (cdr last))
(go a)))))
(defun grindcolmac () (list ': (read)))
(defun grindcommac () (list '/, (read)))
(defun grindatmac () (cons '@ (read)))
(defun grindexmac ()
(prog (c f)
(setq c (grindnxtchr))
ta (cond ((setq f (assq c '((" /!") (@ /!@) ($ /!$))))
(tyi)
(return (cons (cadr f) (read))))
((setq f (assq c
'((? /!?) (/' /!/') (> /!>) (/, /!/,)
(< /!<) (/; /!/;))))
(tyi)
(setq f (cadr f)))
(t (setq c (error 'bad/ /!/ macro
c
'wrng-type-arg))
(go ta)))
(return (cond ((grindseparator (grindnxtchr))
(list f ()))
((atom (setq c (read))) (list f c))
(t (cons f c))))))
(defun grindnxtchr () (ascii (tyipeek)))
(defun grindseparator (char) (memq char '(| | | | |)|))) ;space, tab, rparens

1520
src/lspsrc/grinde.462 Normal file
View File

File diff suppressed because it is too large Load Diff

371
src/lspsrc/lap.110 Executable file
View File

@@ -0,0 +1,371 @@
;;; -*-LISP-*-
;;; **************************************************************
;;; ***** MACLISP ****** LISP IN-CORE ASSEMBLER (LAP) ************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
(HERALD LAP /110)
(DECLARE (SPECIAL LOC ORGIN AMBIG UNDEF RMSYM TTSR/| POPSYM/|
SIDEV CNST/| /|GWD LAPEVAL-Q/|)
(*EXPR GETMIDASOP POPSYM/| /|GWD /|RPATCH LAPEVAL-Q/|)
(*FEXPR LAP)
(GENPREFIX |/|Lap|)
(MAPEX T)
(FIXNUM (LAPEVAL) (1WD/| NIL FIXNUM) (SQOZ/|)
(SPAGETTI/| FIXNUM) II NN WRD MM)
(NOTYPE (ADDRHAK/| FIXNUM FIXNUM) (/|RPATCH FIXNUM)))
(DEFUN CK@ MACRO (X)
'(AND (EQ (CAR X) '@)
(PROG2 (SETQ WRD (BOOLE 7 WRD 1_22.))
(AND (NULL (SETQ X (CDR X))) (GO B)))))
;CURRENTLY /|GWD HOLDS FIELD NUMBER OF THE FIELD THAT LAPEVAL IS
;WORKING ON. 3 FOR OP, 2 FOR AC, 1 FOR ADR, 0 FOR INDEX
;TTSR/| HOLDS LOC OF CONSTANTS LIKE [1,,1], [2,,2] ETC.
(DEFUN LAPEVAL (X)
(COND ((ATOM X)
(COND ((NOT (SYMBOLP X)) X)
((EQ X '*) (+ ORGIN LOC))
((GET X 'SYM))
((NULL X) 0)
((SETQ SIDEV (COND ((GET X 'UNDEF) () )
((AND (= /|GWD 3) (GETMIDASOP X)))
((GETDDTSYM X))))
(PUTPROP X SIDEV 'SYM))
('T (AND (NOT (MEMQ X UNDEF)) (PUSH X UNDEF))
(PUTPROP X (CONS (CONS LOC /|GWD) (GET X 'UNDEF)) 'UNDEF)
0)))
((MEMQ (CAR X) '(QUOTE FUNCTION)) (LAPEVAL-Q/| (CADR X)))
((EQ (CAR X) 'SPECIAL)
(GCPROTECT (CADR X) 'VALUE) ;MAKUNBOUND WILL
(VALUE-CELL-LOCATION (COND ((BOUNDP (CADR X)) (CADR X))
;RECLAIM VALUE CELLS UNLESS PROTECTED
(T (MAKUNBOUND (CADR X))))))
((EQ (CAR X) '%)
(COND ((AND (SIGNP E (CAR (SETQ SIDEV (CDR X))))
(SETQ SIDEV (CDR SIDEV)) ;FAILURE HERE INDICATES (% 0)
(SIGNP E (CAR SIDEV))
(CDR SIDEV))
((LAMBDA (VAL TYPE)
(COND ((AND (EQ TYPE 'FIXNUM)
(< VAL 16.)
(FIXP (CADR SIDEV))
(= VAL (CADR SIDEV)))
(+ VAL TTSR/|))
((AND (EQ TYPE 'LIST)
(EQ (CAR VAL) 'QUOTE)
(EQ (CADR VAL) 'NIL))
TTSR/|)
((EQ VAL 'FIX1) (- TTSR/| 2))
((EQ VAL 'FLOAT1) (1- TTSR/|))
((SETQ CNST/| (CONS (CONS (CDR X) LOC) CNST/|)) 0)))
(CAR (SETQ SIDEV (CDR SIDEV)))
(TYPEP (CAR SIDEV))))
((NULL SIDEV) TTSR/|) ;CASE OF (% 0)
((SETQ CNST/| (CONS (CONS (CDR X) LOC) CNST/|)) 0)))
((EQ (CAR X) 'ARRAY) (TTSR/| (CADR X)))
((MEMQ (CAR X) '(ASCII SIXBIT)) (1WD/| (CADR X) 1 (CAR X)))
((EQ (CAR X) 'SQUOZE) (SQOZ/| (CADR X)))
((EQ (CAR X) 'EVAL) (LAPEVAL-Q/| (EVAL (CADR X))))
((MEMQ (CAR X) '(- +)) (APPLY (CAR X) (MAPCAR 'LAPEVAL (CDR X))))
((+ (LAPEVAL (CAR X)) (LAPEVAL (CDR X))))))
(DEFUN LAPEVAL-Q/| (X)
(MAKNUM (COND (GCPROTECT (PUSH X LAPEVAL-Q/|) (CAR LAPEVAL-Q/|))
((AND PURE *PURE)
(COND ((GCPROTECT X '?)) ;PROBE, RETURN NIL IF NOT THERE
((GCPROTECT (PURCOPY X) T))))
((GCPROTECT X T))))) ;PROBE, AND ENTER IF NOT THERE
(DEFUN 1WD/| (X NN ASCIIP)
(DECLARE (FIXNUM I N))
(DO ((I (COND ((SETQ ASCIIP (COND ((EQ ASCIIP 'ASCII) 'T)
('T () )))
(SETQ NN (1+ (* NN 5))) 5)
((SETQ NN (1+ (* NN 6))) 6))
(1- I))
(N 0)
(II 0))
((ZEROP I) (COND (ASCIIP (LSH N 1)) ('T N)))
(SETQ II (GETCHARN X (- NN I)))
(AND (ZEROP II) (RETURN (LSH N (COND (ASCIIP (1+ (* 7 I))) (T (* 6 I))))))
(SETQ N (COND (ASCIIP (+ II (LSH N 7)))
(T (AND (LESSP 96. II 123.) (SETQ II (- II 32.)))
(+ (BOOLE 1 (- II 32.) 63.) (LSH N 6)))))))
(DEFUN SPAGETTI/| (NN)
(SETQ NN (+ LOC NN))
(AND (NOT (< (+ BPORG NN) BPEND))
(NULL (GETSP (+ NN 8)))
((LAMBDA (ERRSET) (ERROR NIL 'NO-CORE? 'FAIL-ACT)) '/|LAP-NIL))
NN)
(DEFUN /|GWD (X)
(PROG (WRD NN)
(COND ((EQ (CAR X) 'SQUOZE) (SETQ WRD (SQOZ/| (CDR X))))
((EQ (CAR X) 'BLOCK)
(SETQ NN (LAPEVAL (CADR X)))
(SETQ LOC (SPAGETTI/| NN))
(DO II (- LOC NN) (1+ II) (= II LOC) (DEPOSIT (+ ORGIN II) 0))
(RETURN NIL))
((COND ((EQ (CAR X) 'ASCII) (SETQ NN 5) T)
((EQ (CAR X) 'SIXBIT) (SETQ NN 6) T))
(SETQ NN (// (+ (FLATC (CADR X)) NN -1) NN))
(SETQ LOC (SPAGETTI/| NN))
(DO ((II 1 (1+ II)) (MM (- (+ ORGIN LOC) NN 1)))
((> II NN))
(DEPOSIT (+ MM II) (1WD/| (CADR X) II (CAR X))))
(RETURN NIL))
(T (SETQ /|GWD 3 WRD (LAPEVAL (CAR X)))
(COND ((SETQ X (CDR X))
(CK@)
(SETQ /|GWD 2 NN (LAPEVAL (CAR X)))
(SETQ WRD (+ WRD (LSH (BOOLE 1 NN 15.) 23.)))
(COND ((SETQ X (CDR X))
(CK@)
(SETQ /|GWD 1 NN (LAPEVAL (CAR X)))
(SETQ WRD (BOOLE 7 (BOOLE 1 WRD -1_18.)
(BOOLE 1 (+ WRD NN) 262143.)))
(COND ((SETQ X (CDR X))
(CK@)
(SETQ /|GWD 0 NN (LAPEVAL (CAR X)))
(SETQ WRD (+ WRD (ROT NN 18.)))))))))))
B (DEPOSIT (+ ORGIN LOC) WRD)
(SETQ LOC (SPAGETTI/| 1))
(RETURN (AND (LESSP 11. (SETQ WRD (LSH WRD -27.)) 20.) ;Returns T iff opcode
(ZEROP (BOOLE 1 WRD 2)))))) ; is smashable CALL type
(DEFUN LAP FEXPR (TAG) (LAP-IT-UP TAG NIL))
(DEFUN LAP-A-LIST (LLL) (AND LLL (LAP-IT-UP (CDAR LLL) LLL)))
(DEFUN LAP-IT-UP (TAG LLL)
((LAMBDA (BASE IBASE)
(PROG (LOC ORGIN SIDEV AMBIG UNDEF RMSYM /|GWD POPSYM/| NORET TEM
DDT DDTP DSYMSONLY WINP ENTRYPTS SL SYFLG SMBLS LL
CNST/|)
(SETQ NORET T LOC 0)
(GETMIDASOP NIL) ;LET GETMIDASOP BE AUTOLOADED IN IF NECESSARY
(COND (PURE (AND (NOT (NUMBERP PURE)) (SETQ PURE 1))
(LAPSETUP/| 'T PURE)))
(SETQ ORGIN BPORG DDTP (SETQ SYFLG SYMBOLS))
(AND (NULL TAG) (RETURN () ))
(SETQ ENTRYPTS (LIST (LIST (CAR TAG) ORGIN NIL (CADR TAG))))
;( . (FUN 125 (() . 3) SUBR) . )
(ERRSET
(PROG ()
A (COND (LL (SETQ SL (CAR LL))
(POP LL)
(COND ((NULL SL)
(POPSYM/| (CAR LL) (CADR LL))
(SETQ LL (CDDR LL))
(GO A))))
(LLL (POP LLL)
(AND (NULL (SETQ SL (CAR LLL)))
(SETQ LLL T)
(GO END)))
(T (AND (NULL (SETQ SL (READ () ))) (GO END))))
(COND ((ATOM SL)
(COND ((EQ (TYPEP SL) 'SYMBOL)
(DEFSYM SL (+ ORGIN LOC))
(COND (SYFLG (PUSH (CONS SL LOC) SMBLS))))))
((EQ (CAR SL) 'ARGS)
(AND (SETQ TEM (ASSQ (CADR SL) ENTRYPTS))
(RPLACA (CDDR TEM) (CADDR SL))))
((EQ (CAR SL) 'ENTRY)
(PUSH (LIST (CADR SL)
(+ LOC ORGIN)
()
(COND ((CADDR SL)) ((CADR TAG))))
ENTRYPTS))
((EQ (CAR SL) 'DEFSYM) (DEFLST/| (CDR SL)))
((EQ (CAR SL) 'BEGIN)
(SETQ TEM (EVAL (CADR SL)))
(SETQ LL (APPEND (EVAL (CADDR SL)) ;BLOCK BODY
'(() )
(LIST TEM
(MAPCAR
'(LAMBDA (X)
(AND (SETQ X (REMPROP X 'SYM))
(CADR X)))
TEM))
LL))
(GO A))
((EQ (CAR SL) 'DDTSYMS) (SETQ DSYMSONLY (APPEND (CDR SL) DSYMSONLY)))
((EQ (CAR SL) 'SYMBOLS)
(SETQ SYFLG (CADR SL))
(SETQ DDTP T))
((EQ (CAR SL) 'EVAL)
(MAPC (FUNCTION EVAL) (CDR SL)))
((EQ (CAR SL) 'COMMENT))
(T (AND (/|GWD SL)
PURE
(LAPSETUP/| (MUNKAM (+ ORGIN LOC -1)) PURE))))
(GO A)
END (SETQ WINP 'UNDEF)
;INDICATES THAT THE CLOSING NIL HAS BEEN READ
(MAPC '(LAMBDA (X) (/|RPATCH LOC (CDR X) () )
(/|GWD (CAR X)) () )
(NREVERSE (PROG2 () CNST/| (SETQ CNST/| () ))))
(AND CNST/| (GO END))
END1 (COND (UNDEF
(SETQ UNDEF
(MAPCAN
'(LAMBDA (X)
(COND ((SETQ SIDEV (GETDDTSYM X))
(PUSH X DDT)
(DEFSYM X SIDEV)
() )
((AND (EQ WINP 'SYM) (SETQ SIDEV (GET X 'SYM)))
(DEFSYM X SIDEV)
() )
(T (LIST X))))
(PROG2 () UNDEF (SETQ UNDEF () ))))
(COND ((AND DDT (STATUS NOFEATURE NOLDMSG))
(PRINC '|Symbols obtained from DDT: |) (PRINT DDT)))
(AND (EQ WINP 'SYM) (GO END2))))
(COND ((OR SMBLS DSYMSONLY)
(AND DSYMSONLY
(SETQ SMBLS (NCONC (MAPCAN '(LAMBDA (X)
(AND (SETQ X (CONS X (GET X 'SYM)))
(CDR X)
(LIST X)))
DSYMSONLY)
SMBLS)))
(MAPC '(LAMBDA (X) (AND (OR (NULL DSYMSONLY) (MEMQ (CAR X) DSYMSONLY))
(PUTDDTSYM (CAR X) (+ (CDR X) ORGIN))))
SMBLS)))
(COND ((COND (DSYMSONLY (MEMQ (CAR ENTRYPTS) DSYMSONLY))
(DDTP))
(MAPC (FUNCTION PUTDDTSYM)
(MAPCAR (FUNCTION CAR) ENTRYPTS)
(MAPCAR (FUNCTION CADR) ENTRYPTS))))
(SETQ ENTRYPTS (MAPCAR 'SET-ENTRY/| ENTRYPTS))
(COND ((AND UNDEF (EQ WINP 'UNDEF))
(OR ((LAMBDA (ERRSET)
(ERRSET (ERROR 'UNDEFINED/ SYMBOLS/ -/ LAP
(LIST 'GETDDTSYM UNDEF)
'FAIL-ACT)
() ))
'/|LAP-NIL)
(RETURN () ))
(SETQ WINP 'SYM)
(GO END1)))
END2 (AND (NULL UNDEF) (SETQ WINP T))))
(LREMPROP/| RMSYM 'SYM)
(COND (UNDEF (COND (WINP (PRINC 'UNDEFINED/ SYMBOLS:/ ) (PRINT UNDEF)))
(LREMPROP/| UNDEF 'UNDEF)))
(COND (AMBIG (PRINC 'MULTIPLY-DEFINED/ SYMBOLS:/ ) (PRINT AMBIG)
(POPSYM/| POPSYM/| () )))
(COND ((NOT (EQ WINP T))
(COND ((AND ^Q (NULL WINP) (NULL LLL))
(DO () ((NULL (READ () ))))))
(PRINC (CAR TAG)) (PRINC 'ABORTED/ AFTER/ )
(PRINC LOC) (PRINC '/ WORDS/î)
(GCTWA)
(RETURN () ))
('T (SETQ BPORG (+ ORGIN LOC))))
(GCTWA)
(RETURN (CONS BPORG ENTRYPTS))))
8. 8.))
(DEFUN LREMPROP/| (L PROP) (MAPC '(LAMBDA (X) (REMPROP X PROP)) L) NIL)
(DEFUN DEFSYM (SYM VAL)
(PROG (SL)
(COND ((SETQ SL (GET SYM 'UNDEF))
(/|RPATCH VAL SL T)
(REMPROP SYM 'UNDEF)
(SETQ UNDEF (DELQ SYM UNDEF 1)))
((SETQ SL (GET SYM 'SYM))
(COND ((= SL VAL) (RETURN () ))
((NOT (MEMQ SYM AMBIG))
(SETQ AMBIG (CONS SYM AMBIG))
(PUSH (CONS SYM SL) POPSYM/|)))))
(PUSH SYM RMSYM)
(PUTPROP SYM VAL 'SYM)))
(DEFUN DEFLST/| (L) (DO L L (CDDR L) (NULL L) (DEFSYM (CAR L) (EVAL (CADR L)))))
(DEFUN POPSYM/| (L Y)
(PROG (SYM VAL)
A (COND ((NULL L) (RETURN () ))
((NULL Y) (SETQ SYM (CAAR L) VAL (CDAR L)))
(T (SETQ SYM (CAR L) VAL (CAR Y)) (POP Y)))
(POP L)
(COND (VAL (PUTPROP SYM VAL 'SYM))
((REMPROP SYM 'SYM)))
(GO A)))
(DEFUN ADDRHAK/| (ADDR VAL)
(PROG (II NN)
(SETQ NN (EXAMINE (SETQ II (+ ORGIN ADDR))))
(DEPOSIT II (BOOLE 7 (BOOLE 4 NN 262143.)
(BOOLE 1 (+ VAL NN) 262143.)))))
(DEFUN /|RPATCH (VAL L FL)
(DECLARE (FIXNUM VAL))
(COND ((NULL FL) (ADDRHAK/| L (+ ORGIN VAL)))
((DO ((Y L (CDR Y)) (II 0) (NN 0)) ((NULL Y))
(COND ((= (CDAR Y) 1) (ADDRHAK/| (CAAR Y) VAL))
(T (SETQ II (+ ORGIN (CAAR Y)))
(SETQ NN (COND ((= (CDAR Y) 2) (LSH VAL 23.))
((= (CDAR Y) 0) (ROT VAL 18.))
(T VAL)))
(DEPOSIT II (+ (EXAMINE II) NN))))))))
(DEFUN SET-ENTRY/| (X)
((LAMBDA (SL SYFLG)
(COND ((AND SL FASLOAD)
(TERPRI)
(PRINC 'CAUTION/!/ / )
(PRINC (CAR X))
(COND ((SYSP (CAR X))
(PRINC '/,/ A/ SYSTEM/ ))
((PRINC '/,/ A/ USER/ )))
(PRINC (CAR SL))
(PRINC '/,/ IS/ BEING/ REDEFINED)
(TERPRI)
(DO () ((NULL (REMPROP (CAR X) SYFLG))))))
(AND (MEMQ SYFLG '(SUBR FSUBR LSUBR)) (ARGS (CAR X) (CADDR X)))
(PUTPROP (CAR X) (MUNKAM (CADR X)) SYFLG)
(AND PURE PURCLOBRL
(DO ((Y PURCLOBRL (CDR Y)) (BY (SETQ SL (CONS () PURCLOBRL))))
((NULL Y) (SETQ PURCLOBRL (CDR SL)))
(COND ((AND (EQ (MUNKAM (EXAMINE (MAKNUM (CAR Y)))) (CAR X))
(NULL (LAPSETUP/| (CAR Y) PURE)))
(RPLACD BY (CDR Y)))
(T (SETQ BY (CDR BY))))))
(LIST (CAR X) SYFLG (CADR X)))
(GETL (CAR X) '(SUBR FSUBR LSUBR))
(CADDDR X)))
(DEFUN /|LAP-NIL (X) NIL) ;FAKE NO-OP FOR BINDING TO "ERRSET"
(DEFUN REMLAP FEXPR (L) (ERROR '|REMLAP NO LONGER EXISTS| () 'FAIL-ACT))
;;; INITIALIZATION FOR LAP
(LAPSETUP/| () PURE)
(DO ((ORGIN 1 (1+ ORGIN))
(UNDEF '(A B C AR1 AR2A T TT D R F P P FLP FXP SP) (CDR UNDEF)))
((NULL UNDEF))
(PUTPROP (CAR UNDEF) ORGIN 'SYM))

555
src/lspsrc/sort.13 Executable file
View File

@@ -0,0 +1,555 @@
;;; **************************************************************
TITLE ***** MACLISP ****** SORT FUNCTIONS **************************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
.FASL
IF1,[
IFE .OSMIDAS-<SIXBIT \ITS\>,[
IFNDEF D10, D10==0
DEFINE $INSRT $%$%$%
.INSRT $%$%$% >
PRINTX \ ==> INSERTED: \
$FNAME .IFNM1
PRINTX \ \
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \ITS\>,
IFE .OSMIDAS-<SIXBIT \DEC\>,[
IFNDEF D10, D10==1
DEFINE $INSRT $%$%$%
.INSRT $%$%$%!.MID
PRINTX \INSERTED: \
$FNAME .IFNM1
PRINTX \.\
$FNAME .IFNM2
PRINTX \
\
TERMIN
] ;END OF IFE .OSMIDAS-<SIXBIT \DEC\>,
IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY???
DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT
ZZX==<FOO>
REPEAT 6,[
IRPNC ZZX_-36,1,1,Q,,[ !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ(\)^_]
IFSN [Q][ ] PRINTX |Q|
TERMIN
ZZX==ZZX_6
]
TERMIN
$INSRT SYS:FASDFS
] ;END OF IF1
VERPRT SORT
;;; THIS ROUTINE IS A "SORT DRIVER". IT TAKES AN ARRAY AND THE ADDRESSES
;;; OF FIVE MANIPULATIVE FUNCTIONS, AND USES THE FUNCTIONS TO SORT THE
;;; CONTENTS OF THE ARRAY. IT IS CALLED AS FOLLOWS:
;;; JSP AR2A,SORT1 ;POINTER TO SAR0 OF ARRAY IS IN AR1
;;; XXXGET ;ARRAY FETCH FUNCTION
;;; XXXPUT ;ARRAY STORE FUNCTION
;;; XXXMOV ;INTRA-ARRAY TRANSFER FUNCTION
;;; XXXCKA ;COMPARE K WITH ARRAY ITEM
;;; XXXCAK ;COMPARE ARRAY ITEM WITH K
;;; XXXTRYI ;TRY TO LET AN INTERRUPT HAPPEN (NON-BIBOP)
;;; ... ;RETURN HERE
;;; CONCEPTUALLY THERE IS AN ACCUMULATOR CALLED "K" WHICH THE SUPPLIED
;;; FUNCTIONS OPERATE ON. XXXGET PUTS THE ARRAY ITEM WHOSE INDEX IS IN
;;; TT AND PLACES IT IN K. XXXPUT STORES K INTO THE ARRAY LOCATION
;;; WHOSE INDEX IS IN TT. XXXMOV TRANSFERS AN ARRAY ITEM (INDEX IN TT)
;;; TO ANOTHER ARRAY LOCATION (INDEX IN D) WITHOUT AFFECTING K.
;;; XXXCKA SKIPS UNLESS K IS STRICTLY LESS THAN THE ARRAY ITEM (INDEX
;;; IN TT). XXXCAK SKIPS UNLESS THE ARRAY ITEM (INDEX IN TT) IS STRICTLY
;;; LESS THAN K. (IN THE LAST TWO SENTENCES, "STRICTLY LESS THAN" MEANS
;;; "UNEQUAL, AND IN CORRECT SORTING ORDER (AS DEFINED BY SOME
;;; PREDICATE)". THE PREDICATE USED TO DETERMINE THIS CAN BE ARBITRARY,
;;; BUT HOPEFULLY WILL IMPOSE SOME MEANINGFUL ORDERING ON THE ITEMS IN
;;; THE ARRAY.)
;;; THE FIVE FUNCTIONS ARE ALL CALLED VIA PUSHJ P,; THE SORT DRIVER
;;; DOES NOT PUSH ANYTHING ELSE ON THE REGULAR PDL, AND THE CALLER MAY
;;; DEPEND ON THIS FACT TO PASS INFORMATION TO THE FIVE FUNCTIONS. THE
;;; FIVE FUNCTIONS MAY DESTROY ANY ARRAY INDICES THEY ARE GIVEN; BUT
;;; AR1, AR2A, D (EXCEPT FOR SRTMOV), R, AND F MUST BE PRESERVED.
;;; A, B, C, T, AND TT MAY BE USED FREELY. THE SORT DRIVER DOES NOT
;;; USE A, B, AND C AT ALL, AND IT USES T ONLY WHEN IT DOES NOT WANT
;;; WHAT IS IN K; HENCE THESE FOUR MAY BE USED BY THE FIVE FUNCTIONS
;;; TO REPRESENT K.
;;; THE ALGORITHM USED IS C.A.R. HOARE'S "QUICKSORT", AS DESCRIBED BY
;;; D.E. KNUTH IN HIS "THE ART OF COMPUTER PROGRAMMING, VOLUME 3, SORTING
;;; AND SEARCHING" (ADDISON-WESLEY, 1973), PAGES 114-123 (Q.V.). THE
;;; ALGORITHM HAS BEEN MODIFIED USING THE SUGGESTION KNUTH MAKES ON PAGE
;;; 122 OF USING RANDOM NUMBERS TO SELECT SUCCESSIVE TEST KEYS, IN ORDER
;;; TO AVOID SUCH WORST CASES AS AN ALREADY SORTED ARRAY!
;;; DETAILS OF THIS IMPLEMENTATION: ACS R AND F CORRESPOND GENERALLY TO
;;; I AND J OF THE ALGORITHM AS KNUTH PRESENTS IT. THE ARRAY INDICES GO
;;; FROM 0 TO N-1 RATHER THAN 1 TO N; THIS IS A TRIVIAL MODIFICATION OF
;;; STEP 1. BOUNDARY CONDITIONS ARE DETECTED IN A SLIGHTLY DIFFERENT
;;; MANNER FROM KNUTH'S, WHICH INVOLVES HAVING A DUMMY KEY AT EACH END
;;; OF THE ARRAY; THE METHOD USED HERE REDUCES THE NUMBER OF
;;; COMPARISONS AND AVOIDS THE PROBLEM OF DETERMINING EXACTLY WHAT
;;; <-INFINITY> AND <INFINITY> SHOULD BE FOR A PARTICULAR PREDICATE.
;;; (REMEMBER, THIS SORT DRIVER WILL OPERATE WITH ANY ARBITRARY
;;; ORDERING PREDICATE; FURTHERMORE, FOR MANY PREDICATES (E.G. ALPHALESSP)
;;; CREATING AN INFINITE KEY IS IMPRACTICAL IF NOT IMPOSSIBLE.) THE
;;; CURRENT (L,R) PAIR IS KEPT ON THE STACK (HERE REPRESENTED BY THE
;;; FIXNUM PDL) AS WELL AS OTHER (L,R) PAIRS: THE PAIR ON TOP IS THE
;;; CURRENT PAIR, AND THE REST ARE BELOW IT. THE VALUE M IN KNUTH'S
;;; ALGORITHM IS HERE A PARAMETER CALLED SORTM.
;;; THE LABELS IN THIS IMPLEMENTATION CORRESPOND IN THE OBVIOUS WAY
;;; TO THE STEP NUMBERS IN KNUTH'S DESCRIPTION OF THE ALGORITHM.
SORTM==10 ;SMALLEST SUBFILE NOT TO USE INSERTION SORT ON
IRPS OP,F,[GET-PUT-MOV-KAC-AKC-RETURN]
IFSE F,-, SORT!OP=<PUSHJ P,@.IRPCNT(AR2A)>
IFSN F,-, SORT!OP=<JRST .IRPCNT(AR2A)>
TERMIN
;;; MAIN SORT DRIVER - POINTER TO SAR0 OF ARRAY IN AR1
SORT1: PUSH FXP,.+1 ;ANYTHING NEGATIVE WILL DO (HRRZI = 551_33)
HRRZI TT,-1
MOVE T,@TTSAR(AR1)
SUBI T,1 ;LARGEST VALID ARRAY INDEX
PUSH FXP,T ;R <- N-1
PUSH FXP,R70" ;L <- 0
SORT2: MOVE R,(FXP) ;I <- L
MOVE F,-1(FXP) ;J <- R
CAIGE F,SORTM(R)
JRST SORT8 ;R-L < M -- USE INSERTION SORT
MOVEI T,0
NCALL 16,.FUNCTION RANDOM
MOVE R,(FXP) ;RANDOM CLOBBERS R,F
MOVE F,-1(FXP)
TLZ TT,400000
MOVEI D,1(F)
SUBI D,(R)
IDIVI T,(D)
ADDI TT,(R) ;Q <- RANDOM BETWEEN L AND R
MOVEI D,(TT)
SORTGET ;K <- ARRAY(Q) ;PRESERVES D!!!
MOVEI TT,(R)
SORTMOV ;ARRAY(Q) <- ARRAY(L)
MOVEI TT,(R)
SORTPUT ;ARRAY(L) <- K
SORT3: CAMG F,(FXP) ;MUSTN'T RUN OFF END OF SUBFILE
JRST SORT4
MOVEI TT,(F) ;WHILE K < ARRAY(J) DO J <- J-1;
SORTKAC
SOJA F,SORT3
SORT4: CAIGE R,(F)
JRST SORT4A
MOVEI TT,(R) ;I >= J
SORTPUT ;ARRAY(J) <- K
JRST SORT7
SORT4A: MOVEI TT,(F) ;I < J
MOVEI D,(R)
SORTMOV ;ARRAY(I) <- ARRAY(J)
ADDI R,1 ;I <- I+1
SORT5: CAML R,-1(FXP) ;BOUNDARY CASE
JRST SORT6
MOVEI TT,(R) ;WHILE ARRAY(I) < K DO I <- I-1;
SORTAKC
AOJA R,SORT5
SORT6: CAIL R,(F)
JRST SORT6A
MOVEI TT,(R) ;I < J
MOVEI D,(F) ;ARRAY(J) <- ARRAY(I)
SORTMOV
SOJA F,SORT3 ;J <- J-1
SORT6A: MOVEI TT,(F) ;I >= J
SORTPUT ;ARRAY(J) <- K
MOVEI R,(F) ;I <- J
SORT7: CAMN R,(FXP) ;LOSING BOUNDARY CASES
JRST SORT7B ; KNUTH DIDN'T MENTION!!!
CAMN R,-1(FXP)
JRST SORT7C
PUSH FXP,-1(FXP) ;COPY (L,R) PAIR ONTO STACK
PUSH FXP,-1(FXP)
MOVEI T,(R)
ADDI T,(R)
SUB T,(FXP) ;2*I-L
MOVEI TT,-1(R)
MOVEI D,1(R)
CAMLE T,-1(FXP)
JRST SORT7A
MOVEM D,-2(FXP) ;2*I-L <= R
MOVEM TT,-1(FXP) ;(I+1,R) ON STACK
JRST SORT2 ;R <- I-1
SORT7A: MOVEM TT,-3(FXP) ;2*I-L > R
MOVEM D,(FXP) ;(L,I-1) ON STACK
JRST SORT2 ;L <- I+1
SORT7B: AOSA (FXP)
SORT7C: SOS -1(FXP)
JRST SORT2
SORT8: CAIN R,(F) ;INSERTION SORT
JRST SORT9
MOVEI F,1(R)
SORT8A: MOVEI TT,(F)
SORTGET
MOVEI R,-1(F)
MOVEI TT,(R)
JRST SORT8C
SORT8B: MOVEI TT,(R)
MOVEI D,1(R)
SORTMOV
SOS TT,R
CAMGE R,(FXP)
JRST SORT8D
SORT8C: SORTKAC
JRST SORT8B
SORT8D: MOVEI TT,1(R)
SORTPUT
CAMGE F,-1(FXP)
AOJA F,SORT8A
SORT9: SUB FXP,R70+2 ;POP CURRENT (L,R) PAIR
SKIPL (FXP) ;SKIP IF DONE
JRST SORT2 ;ELSE GO SORT ANOTHER SUBFILE
POP FXP,T ;POP STACK MARKER
SORTRETURN ;ALL DONE - HOORAY!!!
;;; FOR LISTS, WE USE A WINNING MERGE SORT WHICH DOES MANY RPLACD'S
;;; TO GET THE LIST IN ORDER. THIS ALGORITHM WAS ORIGINALLY
;;; CODED IN LISP BY MJF, AND TRANSCRIBED INTO MIDAS BY GLS.
;;; IT OPERATES BY CONSIDERING THE GIVEN LIST TO BE THE FRONTIER
;;; OF A (POSSIBLY INCOMPLETE) BINARY TREE, AND AT EACH NODE
;;; MERGES THE TWO NODES BELOW IT. INSTEAD OF THE USUAL METHOD
;;; OF MERGING ALL PAIRS, THEN ALL PAIRS OF PAIRS, ETC., THIS
;;; IMPLEMENTATION EFFECTIVELY DOES A SUFFIX WALK OVER THE BINARY
;;; TREE (THUS IT CAN GRAB ITEMS SEQUENTIALLY OFF THE GIVEN LIST.)
;;; WARNING: LIKE DELQ AND OTHERS, THE SAFE WAY TO USE THIS
;;; FUNCTION IS (SETQ FOO (ALPHASORT FOO)) OR WHATEVER.
;;; TO ILLUMINATE THE MACHINATIONS OF THE HACKISH CODE BELOW,
;;; A MODIFIED FORM OF THE LISP ENCODING IS HERE GIVEN.
;;;
;;; (DECLARE (SPECIAL LESSP-PREDICATE F C))
;;;
;;; (DEFUN MSORT (C LESSP-PREDICATE)
;;; (DO ((TT -1 (1+ TT))
;;; (S)
;;; (F (CONS NIL)))
;;; ((NULL C) S)
;;; (SETQ S (MMERGE S (MPREFX TT)))))
;;;
;;; (DEFUN MPREFX (TT)
;;; (COND ((NULL C) NIL)
;;; ((< TT 1)
;;; (RPLACD (PROG2 NIL C (SETQ C (CDR C))) NIL))
;;; ((MMERGE (MPREFX (1- TT)) (MPREFX (1- TT))))))
;;;
;;; (DEFUN MMERGE (AR1 AR2A)
;;; (PROG (R)
;;; (SETQ R F)
;;; A (COND ((NULL AR1) (RPLACD R AR2A) (RETURN (CDR F)))
;;; ((NULL AR2A) (RPLACD R AR1) (RETURN (CDR F)))
;;; ((FUNCALL LESSP-PREDICATE (CAR AR2A) (CAR AR1))
;;; (RPLACD R (SETQ R AR2A))
;;; (SETQ AR2A (CDR AR2A)))
;;; (T (RPLACD R (SETQ R AR1))
;;; (SETQ AR1 (CDR AR1))))
;;; (GO A)))
.ENTRY SORT SUBR 000003
SORT: MOVE T,[SORTFN,,MSORTFN]
CAIN B,.ATOM ALPHALESSP
MOVE T,[AALPHALESSP,,MALPHALESSP]
JRST ASORT1
.ENTRY SORTCAR SUBR 000003
SORTCAR: MOVE T,[SORTCFN,,MSORTCFN]
CAIN B,.ATOM ALPHALESSP
MOVE T,[ALPCAR,,MALPCAR]
ASORT1: HRLI B,(CALL 2,)
JUMPE A,CCPOPJ
PUSH P,A ;SAVE A ON STACK (TO PROTECT IF ARRAY)
PUSH P,T ;SAVE ADDRESS OF PREDICATE HANDLER
PUSH P,B ;SAVE CALL 2, ON STACK FOR SORT/SORTCAR
MOVE B,A
CALL 1,.FUNCTION ATOM
EXCH A,B
JUMPN B,KWIKSORT ;HMM... MUST BE AN ARRAY, USE QUICKSORT
MSORT: HRRZS -1(P) ;WANT PREDICATE HANDLER FROM RH OF T
PUSH P,. ;RANDOM GC-PROTECTED SLOT FOR MMERGE
SETZM -3(P) ;DON'T NEED TO PROTECT ARG - USE SLOT
SETO TT, ; TO REPRESENT S
MOVEI C,(A)
MOVEI F,(P) ;F POINTS TO PDL FROBS FOR US
MSORT1: PUSHJ P,MPREFX
MOVE AR1,-3(F)
PUSHJ P,MMERGE
MOVEM AR2A,-3(F)
ADDI TT,1
JUMPN C,MSORT1
SUB P,R70+3
SOPOPAJ: POP P,A
POPJ P,
MALPCAR: HLRZ A,(A)
HLRZ B,(B)
MALPHALESSP: PUSH FXP,TT ;ALPHALESSP, BUT SAVES TT, R AND F
PUSH FXP,R
PUSH FXP,F
CALL 2,.FUNCTION ALPHALESSP
POP FXP,F
POP FXP,R
POP FXP,TT
POPJ P,
ALPCAR: HLRZ A,(A)
HLRZ B,(B)
AALPHALESSP: JCALL 2,.FUNCTION ALPHALESSP
MPREFX: MOVEI AR2A,(C)
MPREF2: JUMPE C,MPREF9
JUMPG TT,MPREF4
HRRZ C,(C)
HLLZS (AR2A)
MPREF9: POPJ P,
MPREF4: SUBI TT,1 ;DECREMENT TT FOR CALLS TO MPREFX
PUSHJ P,MPREF2
PUSH P,AR2A
PUSHJ P,MPREFX
POP P,AR1
ADDI TT,1 ;INCR TT, AND FALL INTO MMERGE
MMERGE: MOVEI R,(F)
JUMPE AR2A,MMERG3
JRST MMERG1
MMERG4: HRRM AR1,(R)
MOVEI R,(AR1)
HRRZ AR1,(AR1)
MMERG1: JUMPN AR1,MMERG2
HRRM AR2A,(R)
HRRZ AR2A,(F)
POPJ P,
MMERG2: HLRZ A,(AR2A)
HLRZ B,(AR1)
PUSHJ P,@-2(F)
JUMPE A,MMERG4
HRRM AR2A,(R)
MOVEI R,(AR2A)
HRRZ AR2A,(AR2A)
JUMPN AR2A,MMERG2
MMERG3: HRRM AR1,(R)
HRRZ AR2A,(F)
POPJ P,
MSORTCFN: HLRZ A,(A) ;TAKE CAR OF BOTH ITEMS
HLRZ B,(B)
MSORTFN: PUSH P,C ;SAVE UP ACS
PUSH P,AR1
PUSH P,AR2A
PUSH FXP,TT
PUSH FXP,R
PUSH FXP,F
XCT -1(F) ;CALL PREDICATE (MAYBE IT GETS SMASHED)
POP FXP,F ;RESTORE ACS
POP FXP,R
POP FXP,TT
POP P,AR2A
POP P,AR1
POP P,C
POPJ P,
KWIKSORT: HLRZS -1(P) ;WANT PREDICATE HANDLER FROM LH OF T
PUSHJ P,AREGET ;GET SAR0
MOVEI AR1,(A)
JSP AR2A,SORT1 ;MOBY SORT!!!
ASRGET
ASRPUT
ASRMOV
ASRCKA
ASRCAK
SUB P,R70+2 ;POP JUNK
JRST SOPOPAJ ;RETURN FIRST ARG
ASRGET: ROT TT,-1 ;FETCH FROM S-EXP ARRAY
JUMPL TT,ASRGT1 ;USE C TO REPRESENT K
HLRZ C,@TTSAR(AR1)
CSORTFN: POPJ P,SORTFN
ASRGT1: HRRZ C,@TTSAR(AR1)
POPJ P,
ASRPUT: ROT TT,-1 ;STORE INTO S-EXP ARRAY
JUMPL TT,ASRPT1 ;USE C TO REPRESENT K
HRLM C,@TTSAR(AR1)
POPJ P,
ASRPT1: HRRM C,@TTSAR(AR1)
POPJ P,
ASRMOV: ROTC TT,-1 ;FIRST FETCH...
JUMPGE D,ASRMV1 ; (WITHOUT DISTURBING C!!!)
SKIPA T,@TTSAR(AR1)
ASRMV1: HLRZ T,@TTSAR(AR1)
EXCH TT,D
JUMPL D,ASRMV2 ;THEN STORE
HRLM T,@TTSAR(AR1)
POPJ P,
ASRMV2: HRRM T,@TTSAR(AR1)
POPJ P,
ASRCKA: TLOA AR2A,1 ;COMPARE K TO ARRAY
ASRCAK: TLZ AR2A,1 ;COMPARE ARRAY TO K
ROT TT,-1
JUMPL TT,ASRCK1 ;FETCH ARRAY ITEM INTO A
HLRZ A,@TTSAR(AR1)
JRST ASRCK2
ASRCK1: HRRZ A,@TTSAR(AR1)
ASRCK2: MOVEI B,(C) ;PUT K INTO B
TLNE AR2A,1
EXCH A,B ;MAYBE INVERT ORDER OF COMPARISON
PUSHJ P,@-2(P) ;COMPARE (MUST PRESERVE C,AR1,AR2A,R,F)
SKIPN A ;SKIP UNLESS COMPARE WAS TRUE
AOS (P)
POPJ P,
;;; PDL STRUCTURE ON ENTRY TO SORTFN
;;; ... ;FIRST ARG OF SORT/SORTCAR
;;; SORTFN ;OR MAYBE SORTCFN
;;; CALL 2,PREDFN ;USER SUPPLIED FN
;;; ... ;(NON-BIBOP ONLY) FAKE SAR0
;;; ... ;RETURN ADDRESS FROM SORT1
;;; ... ;RETURN ADDRESS FROM ASRCKA/ASRCAK
SORTCFN: HLRZ A,(A) ;FOR SORTCAR, TAKE CAR OF EACH ITEM
HLRZ B,(B)
SORTFN: PUSH P,C ;SAVE ACS
PUSH P,AR1
PUSH P,AR2A
PUSH FXP,R
PUSH FXP,F
XCT -5(P) ;XCT THE CALL 2, ON THE STACK
POP FXP,F ;RESTORE ACS
POP FXP,R
POP P,AR2A
POP P,AR1
POP P,C
POPJ P,
IFN 0,[ ;FOR NEW ARRAY SCHEME ONLY!!!
IFN BIBOP,[
;;; ***** THIS CODE LOSES GROSSLY - NEED TO RETHINK WHOLE MESS *****
NUMSORT: PUSH P,A ;SAVE FIRST ARG
MOVEI AR2A,(B) ;SAVE SECOND ARG IN AR2A
PUSHJ P,AREGET ;GET SAR0 OF ARRAY
SKIPN A,AR2A ;MAYBE THE SECOND ARG IS ALSO AN ARRAY?
JRST NSR1
PUSH P,A ;YUP - SAVE IT TOO
PUSHJ P,AREGET ;GET SAR0 OF SECOND ARRAY
MOVNI TT,1
MOVE D,@(T) ;CHECK OUT LENGTHS OF ARRAYS
CAME D,@(AR1)
JRST NSRER
HRLI T,(@) ;SET @ BIT FOR DOUBLE INDIRECTION
PUSH P,T
TLO AR1,1 ;SET FLAG FOR SECOND ARRAY ARG
NSR1: JSP AR2A,SORT1 ;MOBY SORT!!!
NSRGET
NSRPUT
NSRMOV
NSRCKA
NSRCAK
POP P,A
TLNE AR1,1
SUB P,R70+1 ;IF SECOND ARG WAS ARRAY, MUST POP FIRST
POPJ P,
NSRER:
POP P,A ;CONS UP ARGS FOR FAIL-ACT
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVEI B,.ATOM NUMSORT
PUSHJ P,XCONS
FAC [ARRAY LENGTHS DIFFER!]
;;; IFN BIBOP
;;; IFN 0 (NEW ARRAYS ONLY!)
NSRGET: MOVE T,@(AR1) ;FETCH FROM NUMBER ARRAY
TLNN AR1,1 ;USE T TO REPRESENT K
POPJ P,
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP FETCH
JUMPL TT,NSRGT1 ;USE C AS FOR ALPHASORT
HLRZ C,@-1(P)
POPJ P,
NSRGT1: HRRZ C,@-1(P)
POPJ P,
NSRPUT: MOVEM T,@(AR1) ;STORE INTO NUMBER ARRAY
TLNN AR1,1 ;USE T TO REPRESENT K
POPJ P,
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP STORE
JUMPL TT,NSRPT1 ;ITEM IS IN C
HRLM C,@-1(P)
POPJ P,
NSRPT1: HRRM C,@-1(P)
POPJ P,
NSRMOV: TLNN AR1,1 ;ARRAY TRANSFER - MUST NOT ALTER T OR C
JRST NSRMV3
ROT TT,-1 ;FOR SECOND ARRAY, DO S-EXP FETCH INTO B
JUMPL TT,NSRMV1
HLRZ B,@-1(P)
JRST NSRMV2
NSRMV1: HRRZ B,@-1(P)
NSRMV2: ROT TT,1
NSRMV3: MOVE TT,@(AR1) ;TRANSFER WITHIN NUMBER ARRAY
EXCH D,TT
MOVEM D,@(AR1)
TLNN AR1,1
POPJ P,
ROT TT,-1 ;MAYBE ALSO NOW DO AN S-EXP STORE FROM B
JUMPL TT,NSRMV4
HRLM B,@-1(P)
POPJ P,
NSRMV4: HRRM B,@-1(P)
POPJ P,
NSRCKA: CAML T,@(AR1) ;COMPARE K TO ARRAY
AOS (P) ;SKIP UNLESS K < ARRAY
POPJ P,
NSRCAK: CAMG T,@(AR1) ;COMPARE ARRAY TO K
AOS (P) ;SKIP UNLESS ARRAY < K
POPJ P,
] ;END OF IFN BIBOP
] ;END OF IFN 0 (NEW ARRAYS ONLY!)
FASEND

593
src/lspsrc/trace.67 Executable file
View File

@@ -0,0 +1,593 @@
;; -*-LISP-*-
;; ************************************************************
;; **** MACLISP **** LISP FUNCTION TRACING PACKAGE (TRACE) ****
;; ************************************************************
;; * (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY *
;; ***** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *****
;; ************************************************************
;; Trace package now works in both Multics and PDP-10 lisp.
;; REVISIONS:
;; 45 (Rick Grossman, 12/74)
;; Replace the trac1 template with compilable code.
;; Flush trprint in favor of new trace-printer.
;; Make trace, remtrace, untrace compilable.
;; Improve trace-edsub so that this will work:
;; (trace y (x wherein y)), and similarly untrace.
;; Note that (trace (y wherein z) (x wherein y))
;; still partially loses.
;; Have untrace return only the list of actually
;; previously traced functions.
;; 46 (Rick Grossman, 1/75)
;; Add trace-indenter as default print function.
;; Fix bug: (.. value ..) also printed the arg.
;; Put "break" condition within scope of the "cond" one.
;; Fix bug: (trace (foo cond bar1 value)) lost
;; because trace*g4 was referenced in "value"
;; but never set.
;; Fix bug: If FEXPR or MACRO is an atom, loses.
;; Clean up some of the duplicate trace-1 code.
;; Add TRACE-OK-FLAG to prevent tracing calls by trace.
;; Flush definition of PLIST.
;; Change ADD1 to 1+.
;; Replace MIN with open-compilable COND.
;; Flush excess consing in trace-indenter call.
;; 50 (JONL, 1/75)
;; Try to merge Moons hackery with Grossman's latest stuff
;; Add function BREAK-IN
;; Fix bug in TRACE-INDENTER s.t. if TRACE-INDENTATION
;; ever goes to zero, then simply skip indentation.
;; 51 (JONL, 2/75)
;; Use the PRIN1 variable in TRACE-INDENTER.
;; 52 (GROSS, 2/75)
;; Lambda-bind TRACE-INDENTATION (and use a gensym name).
;; 53 (MOON Feb. 25, 1975)
;; Take break out from control of cond, dammit!!
;; This is the only way to break on condition without
;; printing a lot of garbage; also it's a documented feature.
;; 54 (Gls May 7, 1975)
;; Flush occurrences of IOG function for newio.
;; 55 (MACRAK, 26 Aug 1975)
;; Change || to \\ in entry and exit to avoid seeing
;; /|/|. Set mapex to (). Some cosmetics.
;; 57 (JONL JAN 22, 76)
;; fixed parens error in trace-indenter, and flushed the
;; superfluous (BOUNDP 'PRIN1)
;; 59 (JONL FEB 3, 76)
;; added LSUBR to list of properties to be removed by remtrace
;; gave names to some quoted lambda expressions that were being mapped
;;; so that remtrace could remove them.
;; 60 (Macrakis, 29 March '78)
;; Added Macroval. (Trace (Mac Macroval)) lets you see the value
;; returned after the form returned by the macro is evaluated. Useful
;; when you want to consider the macro a function. (Trace Mac (Mac
;; Macroval)) lets you see both parts. Also cleaned up some trivia.
;; 63 (JONL Oct 20, '78)
;; Add ADD1 to the TRACE*COPIES list, and use ADD1 in place 1+.
;; 64 (jonl Nov 1, '78) Print loading message on MSGFILES
;; 65 (JONL Jan 9, '79) Fixed bug in tracing of autoloadables.
;; 66 (JONL Feb 13, '80) installed use of # conditionals, and MACAID
;; style HERALDing.
;; 67 (JONL Jan 29, '81) flushed "(STATUS FEATURE MACAID)" and
;; changed some "NIL"'s into "()".
;; Note: When adding new functions to this file,
;; be sure to put their names in the list in REMTRACE.
(declare
(setq mapex () ) ;why waste space?
(setq defmacro-for-compiling () defmacro-displace-call () )
(special trace-olduuo traced-stuff
trace*g1 trace*g2 trace*g4 trace*g5
trace*copies trace*subr-args trace-printer trace-ok-flag
trace-indent-incr trace-indent-max)
(fixnum ng)
(*fexpr trace untrace remtrace) )
(herald TRACE /67)
(and (fboundp 'remtrace) (remtrace))
(setq-if-unbound trace-printer 'trace-indenter)
(setq trace-olduuo nouuo traced-stuff () trace-ok-flag 't)
;; The flag trace-ok-flag is bound () inside all trace fns.
(setq
trace*subr-args
(list (gensym) (gensym) (gensym) (gensym) (gensym))
trace*g1 (gensym) trace*g2 (gensym)
trace*g4 (gensym) trace*g5 (gensym) )
;; Initial indentation.
(set trace*g5 0)
;; Define remtrace first in case the loading does not finish.
(defun remtrace fexpr (l)
(prog (trace-ok-flag y)
(errset (untrace) ())
(mapc '(lambda (x) ;this map will be expanded anyway
(do ()
((null (setq y (getl x '(expr fexpr subr fsubr lsubr)))))
(remprop x (car y))))
'(trace trace-2 untrace remtrace untrace-1 trace-edsub
trace-indenter break-in break-in-1))
(nouuo trace-olduuo)
(sstatus nofeature trace)
(gctwa)))
(defun untrace fexpr (l)
(prog (trace-ok-flag)
(cond
(l (setq l (mapcan 'untrace-1 l)))
((setq l (mapcan 'untrace-1 (trace)))
(and traced-stuff (progn (print 'lossage) (print (trace))))))
(and (null traced-stuff) (nouuo trace-olduuo))
(return l)))
(defun untrace-1 (x)
(prog (y ret)
a (cond ((null (setq y (assoc x traced-stuff))) (return ret))
((atom (car y))
(and (eq (get (car y) (caddr y)) (cadddr y))
(remprop (car y) (caddr y))))
('t (trace-edsub (cons (caddr y) (caar y))
(caddar y)
(cadr y))))
(setq traced-stuff (delq y traced-stuff))
(setq ret (list x))
(go a)))
(defun trace-edsub (pair sym ind) (prog (y z)
;; Return () if lose.
(and (setq y (assq sym traced-stuff))
(eq ind (caddr y))
(setq z (getl sym (list ind)))
(eq (cadddr y) (cadr z))
;; We want to munge the original definition,
;; not the trace kludgery.
;; Note that this partially loses for traced macros,
;; since we munge the macro property, not the
;; trace-generated fexpr one.
(setq sym (cdr z)) )
(return
(cond
((setq y (get sym ind))
(putprop sym (sublis (list pair) y) ind) ) ) ) ))
;; Define the code to produce the trace stuff.
(defun qu* macro (x) (prog (y)
(or
(and (cdr x) (null (cddr x)) (eq (caadr x) 'quote))
(error 'qu*-lossage x) )
(setq y (qu*1 (cadadr x)))
(rplaca x (car y)) (rplacd x (cdr y))
(return y) ))
(declare (eval (read)))
(defun qu*1 (x) (prog (y)
(return
(cond
((atom x) (list 'quote x))
((eq (car x) 'ev) (cadr x))
('t
(setq y
(cond
((atom (car x))
(list 'cons
(list 'quote (car x))
(qu*1 (cdr x)) ) )
((eq (caar x) 'ev*)
(list 'append
(cadar x)
(qu*1 (cdr x)) ) )
((list 'cons
(qu*1 (car x))
(qu*1 (cdr x)) )) ) )
(and (not (atom (cadr y))) (not (atom (caddr y)))
(eq (caadr y) 'quote) (eq (caaddr y) 'quote)
(setq y (list 'quote (eval y))) )
(return y) ) ) ) ))
(defun trace-1 macro (dummy)
'((lambda (t1 in-vals)
(sublis trace*copies
(qu* (quote
(lambda (ev (cond (c) (gg) (g (car g)) (trace*g1)))
((lambda
((ev trace*g2) (ev trace*g1)
(ev* (cond ((null q) (list y))))
(ev* (cond (f (list trace*g4))))
(ev* (cond (p (list p))))
(ev* (cond
((eq print 'trace-indenter) (list trace*g5)) )) )
(ev* (and f (list (list 'setq trace*g4 (car f)))))
(ev*
(cond
((or ne (memq (car m) '(arg both)))
(setq t1 (cond
((eq print 'trace-indenter)
(list print y ''enter (list 'quote y)
(cond
((memq (car m) '(arg both)) trace*g2)
((list 'quote trace*g2)) )
(and (or n ne) (cons 'list (append ne n)))
trace*g5 ) )
((qu* (quote
((ev print)
(list (ev y)
'enter
'(ev y)
(ev*
(cond
((memq (car m) '(arg both))
(list trace*g2) ) ) )
(ev* ne)
(ev* n) ) ) ))) ))
(cond
((or f fe)
;; There is a COND or ENTRYCOND
(qu* (quote
((and
(ev* (and f (list trace*g4)))
(ev* (and fe (list (car fe))))
(ev t1) )) )) )
((list t1)) )) ) )
(ev* (and break (list
(list 'break
y
break ) )))
(ev
(cond
(q (list 'apply (list 'quote y) trace*g2))
(mac? (list 'setq trace*g1
(list 'eval (list 'apply (list 'quote y) trace*g2))))
((list 'setq trace*g1
(list 'apply (list 'quote y) trace*g2)))))
(ev*
(cond
((and (null q)
(or nx (memq (car m) '(value both))))
(setq t1 (cond
((eq print 'trace-indenter)
(list print y ''exit (list 'quote y)
(cond
((memq (car m) '(value both)) trace*g1)
((list 'quote trace*g2)))
(and (or n nx) (cons 'list (append nx n)))
trace*g5 ) )
((qu* (quote
((ev print)
(list (ev y)
'exit
'(ev y)
(ev*
(cond
((memq (car m) '(value both))
(list trace*g1))))
(ev* nx)
(ev* n))))))))
(cond
((or f fx)
;; There is a COND or EXITCOND
(qu* (quote
((and
(ev* (and f (list trace*g4)))
(ev* (and fx (list (car fx))))
(ev t1))))))
((list t1))))))
(ev* (cond (mac? (list (list 'list ''quote trace*g1)))
((null q) (list trace*g1)))))
;; lambda args
(ev
(setq in-vals
(cond
(c (car c))
(gg (list 'listify gg))
(g (cons 'list (car g)))
((list 'listify trace*g1)))))
()
(ev* (cond ((null q) (qu* '((add1 (ev y)))))))
(ev* (cond (f '(() ))))
(ev*
(cond
(p
;; ARGPDL stuff
(qu*
(quote
((cons
(list
(ev*
(cond ((null q) (qu* '((add1 (ev y)))))))
'(ev y)
(ev in-vals))
(ev p))))))))
(ev* (cond ((eq print 'trace-indenter)
(list (list '+ trace*g5 'trace-indent-incr)) )))
))))))
() () ))
;; c is non-() for f-type, holds lambda list
;; cm = (MACRO (LAMBDA ...) ...) if macro.
;; g is non-() for expr type, (car g) is lambda list ;
;; not c or g => l-form
;; gg = lexpr variable (if (), is lsubr).
;; q if non-() means the function is go, throw, etc.,
;; so no return values (etc.) will be hacked.
;; n holds list of extra quantities for typeout
;; traced-stuff =
;; list of currently traced stuff, typically
;; ((a 'trace 'expr newexpr) ...)
;; (((a 'wherein b) 'expr g0003) ...)
;; x = tracee
;; y = new symbol for tracee
;; m = (BOTH/ARGS/VALUE/NIL . stuff-to-print)
;; Keyword values:
;; f: COND
;; fe: ENTRYCOND
;; fx: EXITCOND
;; p: ARGPDL
;; break: BREAK
;; b: (foo WHEREIN bar)
;; ne: ENTRY
;; nx: EXIT
;; Obscure functions:
;; qu* Expand a quoted list, hacking:
;; (EV frob) eval the frob, & use result;
;; (EV* frob) eval, & splice the result in.
;;
;; trace-edsub (pair atom ind): Do sublis on the
;; atom's property.
;; This is used for WHEREIN substitution.
(defun break-in fexpr (l) (apply 'trace (mapcar 'break-in-1 l)))
(defun break-in-1 (x) (subst x 'x '(x break (prog2 (setq x arglist) t))))
(defun trace fexpr (l)
(cond
((null l) (mapcar 'car traced-stuff))
('t (prog2 ()
(mapcan 'trace-2 l)
(and traced-stuff (nouuo 't) (sstatus uuolinks))))))
(defun trace-2 (c)
(prog (x y g gg n ne nx m break f fe fx b
p q cm sube print getl trace-ok-flag mac?)
(setq print trace-printer)
(cond
((atom c) (setq x c c ()))
('t
(setq x (car c))
(setq c (cdr c))
(or (atom x)
;; hack list of functions
(return (mapcar '(lambda (x) (car (apply 'trace
(list (cons x c)))))
x)))) )
(or
(setq getl (getl x '(fexpr fsubr expr subr lsubr macro)))
(progn
(or (setq getl (get x 'autoload)) ;Function have autoload property?
(return (ncons (list '? x 'not 'function))))
(funcall autoload (cons x getl)) ;Try autoloading to get the fun
(or (setq getl (getl x '(fexpr fsubr expr subr lsubr macro)))
(return (ncons (list '? x 'undefined 'after 'autoload))))))
(or (atom (cadr getl)) (eq (caadr getl) 'lambda)
(return (ncons (list '? x 'bad (car getl) 'definition))))
(go y)
l (setq c (cdr c))
l1 (setq c (cdr c))
y (cond
((null c) (setq m '(both)) (go x))
((eq (car c) 'grind)
(setq print 'sprinter) (go l1) )
((eq (car c) 'break)
(setq break (cadr c))
(go l) )
((eq (car c) 'cond)
(setq f (cdr c))
(go l) )
((eq (car c) 'entrycond)
(setq fe (cdr c))
(go l) )
((eq (car c) 'exitcond)
(setq fx (cdr c))
(go l) )
((memq (car c) '(arg value both () nil))
(setq m c)
(go x) )
((eq (car c) 'wherein)
(cond
((or (not (atom (cadr c)))
(null
(setq y
(getl (cadr c) '(expr fexpr macro)) ) ) )
(go wherein-loss) ) )
(untrace-1 (setq g (list x 'wherein (cadr c))))
(setq traced-stuff
(cons
(list g
(car y)
(setq n (copysymbol x ())) )
traced-stuff ) )
(setplist n (plist x))
(or
(trace-edsub (cons x n)
(cadr c)
(car y))
;; This can lose if the EXPR, FEXPR, or MACRO found
;; above is really a tracing frob! Hence:
(go wherein-loss) )
(setq b g)
(setq x n)
(go l) )
((eq (car c) 'argpdl)
(cond
((and (setq p (cadr c)) (eq (typep p) 'symbol))
(set p ())
(go l) )
((return (ncons (list '? 'argpdl p)))) ) )
((eq (car c) 'entry)
(setq ne (cons ''\\ (cadr c)))
(go l) )
((eq (car c) 'macroval) (setq mac? t) (go l))
((eq (car c) 'exit)
(setq nx (cons ''\\ (cadr c)))
(go l) )
((return (ncons (list '? (car c))))) )
wherein-loss (return (ncons (list '? 'wherein (cadr c))))
x (untrace-1 x)
(cond
((setq q (memq x '(go return err throw)))
(cond
((eq (car m) 'value)
(setq m (cons () (cdr m))) )
((eq (car m) 'both)
(setq m (cons 'arg (cdr m))) ) ) ) )
;; copy atom in way that works in any lisp.
(set (setplist (setq y (copysymbol x ())) ()) 0)
;; transfer property list to new trace atom
(setplist y (nconc (plist y) (plist x)))
;;
(setq c
(cond
((memq (car getl) '(fexpr macro))
(cond
((atom (cadr getl)) (list trace*g1))
((cadr (cadr getl)) ) ) )
((eq (car getl) 'fsubr) (list trace*g1)) ) )
(setq cm (cond ((eq (car getl) 'macro) getl)))
(setq g
(cond
((eq (car getl) 'expr)
(cond
((atom (setq g (cadr getl))) ())
((null (cadr g)) (cdr g))
((atom (cadr g))
(setq gg (cadr g))
() )
('t (cdr g)) ) )
((eq (car getl) 'subr)
(cond
((setq g (args x))
(setq g (cond ((> (cdr g) 5)
(do ((ng (- (cdr g) 5) (1- ng))
(l trace*subr-args (cons (gensym) l)))
((zerop ng) l)))
((do ((ng (- 5 (cdr g)) (1- ng))
(l trace*subr-args (cdr l)))
((zerop ng) l)))))
(list g))))))
(and
;; For fns called by TRACE itself, suppress tracing.
(or (memq x
'(*append *delq *nconc args assoc assq boundp cons
copysymbol fixp gctwa get getl last memq apply
ncons nreverse plist princ print putprop remprop
setplist sstatus status sublis terpri typep xcons
trace-indenter sprinter delq error gensym nouuo
prin1 ) )
(eq x prin1) )
(setq f (list
(cond
(f (list 'and 'trace-ok-flag (car f)))
('trace-ok-flag)))))
(setq sube
(list (cons 'recurlev y)
(cons 'arglist trace*g2)))
(setq n
(cond
((cdr m)
(cons ''// (sublis sube (cdr m))) ) ) )
(setq ne (sublis sube (list ne f fe break)))
(setq nx
(sublis
(cons (cons 'fnvalue trace*g1) sube)
(list nx fx) ) )
(setq
f (cadr ne) fe (caddr ne)
break (cadddr ne) ne (car ne) )
(setq fx (cadr nx) nx (car nx))
(setplist
x
(cons
(cond
(cm
(setplist y
(cons 'fexpr (cons (cadr cm) (plist y))) )
'macro )
(c 'fexpr)
('t 'expr) )
(cons (trace-1) (plist x)) ) )
(return
(ncons (cond (b)
('t (setq traced-stuff
(cons (list x 'trace (car (plist x))
(cadr (plist x)))
traced-stuff))
x))))))
(declare (fixnum indentation trace-indent-incr trace-indent-max
n recurlev ) )
(defun trace-indenter (recurlev type fn arg stuff indentation)
(prog (trace-ok-flag)
(setq indentation (- indentation trace-indent-incr))
(terpri)
(do ((n
(cond
((< indentation 0) 0)
((< indentation trace-indent-max) indentation)
(trace-indent-max) )
(1- n)))
((zerop n))
(princ '/ ))
(princ '/() (prin1 recurlev) (princ '/ ) (prin1 type)
(princ '/ ) (prin1 fn)
(cond ((not (eq arg trace*g2))
(princ '/ )
(cond (prin1 (funcall prin1 arg))
((prin1 arg))) ))
(do ((l stuff (cdr l)))
((null l))
(princ '/ )
(cond (prin1 (funcall prin1 (car l)))
((prin1 (car l)))) )
(princ '/)/ )))
(setq trace-indent-incr 2.
trace-indent-max 16.
trace*copies (mapcar '(lambda (x) (cons x (copysymbol x t)))
'(trace-indenter print quote cond list
and setq break apply listify add1)))
(sstatus feature trace)

311
src/lspsrc/vector.74 Executable file
View File

@@ -0,0 +1,311 @@
;;; VECTOR -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; **************************************************************************
;;; *** MacLISP ******** VECTOR support **************************************
;;; **************************************************************************
;;; ******** (c) Copyright 1982 Massachusetts Institute of Technology ********
;;; **************************************************************************
(herald VECTOR /74)
;; This file cannot be run interpretively, due to the dependence upon
;; the SOURCE-TRANS being expanded while compiling -- if you *must*
;; try it interpretively, then just turn the SOURCE-TRANS's into
;; ordinary macros.
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload MACAID)
(subload UMLMAC)
;; Remember, EXTMAC down-loads CERROR
(subload EXTMAC)
(subload DEFSETF)
(subload SUBSEQ)
(subload LOOP)
(setq USE-STRT7 'T MACROS () )
(setq defmacro-for-compiling 'T defmacro-displace-call MACROEXPANDED)
)
(eval-when (eval load compile)
(subload EXTEND)
(cond ((status feature COMPLR)
(special VECTOR-CLASS)
(*lexpr MAKE-VECTOR)))
)
(def-or-autoloadable FLUSH-MACROMEMOS DEFMAX)
(define-loop-path (vector-elements vector-element)
si:loop-sequence-elements-path
(of from to below above downto in by)
vref vector-length vector notype)
;;;; Source-trans's necessary for compiling the subrs
(eval-when (eval compile load)
(defun si:VECTOR-SRCTRNS (x)
(let ((winp () ))
(caseq (car x)
(MAKE-VECTOR (if (= (length x) 2)
(setq x `(SI:MAKE-EXTEND ,(cadr x) VECTOR-CLASS)
winp 'T)))
((VREF VSET) (setq x (cons (if (eq (car x) 'VREF)
'SI:XREF
'SI:XSET)
(cdr x))
winp 'T))
(VECTOR (setq x `(SI:EXTEND VECTOR-CLASS ,.(cdr x)) winp 'T))
(VECTOR-LENGTH (setq x `(SI:EXTEND-LENGTH ,.(cdr x)) winp 'T)))
(values x winp)))
(and
(status feature COMPLR)
(let (y)
(mapc '(lambda (x)
(or (memq 'si:VECTOR-SRCTRNS (setq y (get x 'SOURCE-TRANS)))
(putprop x (cons 'si:VECTOR-SRCTRNS y) 'SOURCE-TRANS)))
'(VECTOR VECTOR-LENGTH VREF VSET MAKE-VECTOR))))
)
;;;; VECTORP,VREF,VSET,MAKE-VECTOR,VECTOR,VECTOR-LENGTH,SET-VECTOR-LENGTH
(defun VECTORP (x) (eq (si:class-typep (class-of x)) 'VECTOR))
(defun VREF (seq index)
(when *RSET
(let ((cnt 1))
(check-subsequence (seq index cnt) 'VECTOR 'VREF)))
(vref seq index))
(defsetf VREF ((() seq index) val) ()
`(VSET ,seq ,index ,val))
(defun VSET (seq index val)
(when *RSET
(let ((cnt 1))
(check-subsequence (seq index cnt) 'VECTOR 'VREF)))
(vset seq index val)
seq)
(defun MAKE-VECTOR (n &optional fill)
(when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'MAKE-VECTOR))
(let ((v (make-vector n)))
(if fill
(do ((i 0 (1+ i)))
((>= i n))
(vset v i fill)))
v))
(defun VECTOR n
(when *RSET (check-type n #'SI:MAX-EXTEND-SIZEP 'VECTOR))
(let ((v (make-vector n)))
(dotimes (i n) (vset v i (arg (1+ i))))
v))
(defun VECTOR-LENGTH (seq)
(when *RSET (check-type seq #'VECTORP 'VECTOR-LENGTH))
(vector-length seq))
(defun SET-VECTOR-LENGTH (seq newsize)
(when *RSET
(let ((i 0))
(check-subsequence (seq i newsize) 'VECTOR 'SET-VECTOR-LENGTH)))
;; What a crock!
(do ((max (1- (hunksize seq)))
(i (+ 2 newsize))
(crock (munkam #o777777)))
((> i max))
(rplacx i seq crock))
seq)
(defun |&restv-ify/|| (n &aux allp)
;; Cooperates with output of DEFUN& to snarf args off pdl and into a VECTOR
(declare (fixnum n arg-offset))
(cond ((< n 0) (setq n (- n))) ;Take ABS of 'n'
('T (setq allp 'T))) ;Are we getting all the args?
(let ((v (make-vector n))
(arg-offset (if allp
1
(- (arg () ) n -1))))
(dotimes (i n) (vset v i (arg (+ i arg-offset))))
v))
(defun |#-MACRO-/(| (x) ;#(...) is VECTOR notation
(let ((form (read)) v)
(if (or x
(and form (atom form))
(and (setq x (cdr (last form))) (atom x)))
(error "Not a proper list for #/(" (list x form)))
(setq v (make-vector (length form)))
(dolist (item form i) (vset v i item))
v))
(defvar /#-MACRO-DATALIST () )
;; An open-coding of SETSYNTAX-SHARP-MACRO
(let ((x (get 'SHARPM 'VERSION))
(y '(#/( T MACRO . |#-MACRO-/(| )))
(cond ((and x (alphalessp x '/82))
(push y /#-MACRO-DATALIST))
('T (if (null (setq x (assoc READTABLE /#-MACRO-DATALIST)))
(push (setq x `(,READTABLE . () )) /#-MACRO-DATALIST))
(push y (cdr x)))))
;;;; DOVECTOR, VECTOR-POSASSQ, SI:COMPONENT-EQUAL, and SI:SUBST-INTO-EXTEND
(defmacro DOVECTOR ((var form index) &rest body &aux (cntr index) vec vecl)
(or cntr (si:gen-local-var cntr))
(si:gen-local-var vec)
(si:gen-local-var vecl)
`(LET ((,vec ,form))
(DO ((,cntr 0 (1+ ,cntr))
(,var)
(,vecl (VECTOR-LENGTH ,vec)))
((= ,cntr ,vecl))
(DECLARE (FIXNUM ,cntr ,vecl))
,.(and var (symbolp var) `((SETQ ,var (VREF ,vec ,cntr))))
,.body)))
(def-or-autoloadable GENTEMP MACAID)
(defun VECTOR-POSASSQ (x v)
(dovector (e v i) (and (pairp e) (eq x (car e)) (return i))))
;; called by EQUAL->VECTOR-CLASS and EQUAL->STRUCT-CLASS
(defun SI:COMPONENT-EQUAL (ob other)
(let ((l1 (si:extend-length ob))
(l2 (si:extend-length other)))
(declare (fixnum l1 l2 i))
(and (= l1 l2)
(do ((i 0 (1+ i)))
((= i l1) 'T)
(if (not (equal (si:xref ob i) (si:xref other i)))
(return () ))))))
;; called by SUBST->VECTOR-CLASS and SUBST->STRUCT-CLASS
(defun SI:SUBST-INTO-EXTEND (ob a b)
(let ((l1 (si:extend-length ob)))
(declare (fixnum l1 i))
(do ((i 0 (1+ i))
(newob (si:make-extend l1 (class-of ob))))
((= i l1) newob)
(si:xset newob i (subst a b (si:xref ob i))))))
;;;; Some methods
(defmethod* (EQUAL VECTOR-CLASS) (obj other-obj)
(cond ((not (vectorp obj))
(+internal-lossage 'VECTORP 'EQUAL->VECTOR-CLASS obj))
((not (vectorp other-obj)) () )
((si:component-equal obj other-obj))))
(defmethod* (SUBST VECTOR-CLASS) (ob a b)
(si:subst-into-extend ob a b))
(DEFVAR VECTOR-PRINLENGTH () )
(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
(DEFVAR SI:PRINLENGTH-EXCESS '|...|)
(DEFMETHOD* (:PRINT-SELF VECTOR-CLASS) (OBJ STREAM DEPTH SLASHIFYP)
(DECLARE (FIXNUM LEN I DEPTH))
;Be careful where you put the declaration for LEN!
(LET ((LEN (VECTOR-LENGTH OBJ)))
(SETQ DEPTH (1+ DEPTH))
(SETQ STREAM (SI:NORMALIZE-STREAM STREAM))
(COND
((= LEN 0) (PRINC "#()" STREAM))
((AND PRINLEVEL (NOT (< DEPTH PRINLEVEL)))
(PRINC SI:PRINLEVEL-EXCESS STREAM))
('T (PRINC "#(" STREAM)
(DO ((I 0 (1+ I)) FL)
((= I LEN) )
(IF FL (TYO #\SPACE STREAM) (SETQ FL 'T))
(COND ((OR (AND VECTOR-PRINLENGTH (NOT (> VECTOR-PRINLENGTH I)))
(AND PRINLENGTH (NOT (> PRINLENGTH I))))
(PRINC SI:PRINLENGTH-EXCESS STREAM)
(RETURN () )))
(PRINT-OBJECT (VREF OBJ I) DEPTH SLASHIFYP STREAM))
(TYO #/) STREAM)))))
(DEFMETHOD* (FLATSIZE VECTOR-CLASS) (OBJ PRINTP DEPTH SLASHIFYP
&AUX (LEN (VECTOR-LENGTH OBJ)))
(AND DEPTH (SETQ DEPTH (1+ DEPTH)))
(COND ((ZEROP LEN) 3)
((AND DEPTH PRINLEVEL (NOT (< DEPTH PRINLEVEL))) 1) ;?
(PRINTP (+ 2 (FLATSIZE-OBJECT (VREF OBJ 0)
PRINTP
DEPTH
SLASHIFYP)))
('T (DO ((I (1- LEN) (1- I))
(CNT 2 (+ CNT
(FLATSIZE-OBJECT (VREF OBJ I)
PRINTP
DEPTH
SLASHIFYP)
1)))
((< I 0) CNT)
(DECLARE (FIXNUM I CNT))))))
(DEFMETHOD* (SPRINT VECTOR-CLASS) (SELF N M)
(IF (= (VECTOR-LENGTH SELF) 0)
(PRINC "#()")
(PROGN (SETQ SELF (TO-LIST SELF))
(PRINC '/#)
(SPRINT1 SELF (GRCHRCT) M))))
(DEFMETHOD* (GFLATSIZE VECTOR-CLASS) (OBJ)
(DO ((LEN (VECTOR-LENGTH OBJ))
(I 0 (1+ I))
(SIZE 2 (+ SIZE (GFLATSIZE (VREF OBJ I)))))
((= I LEN)
(COND ((= LEN 0) 3)
(T (+ SIZE LEN))))
(DECLARE (FIXNUM MAX I SIZE))))
(DEFMETHOD* (SXHASH VECTOR-CLASS) (OB)
(SI:HASH-Q-EXTEND OB #,(sxhash 'VECTOR)))
;;Someday we'd like this hook, but for now there is just the
;; complr feature that lets them go out as hunks. Also, DEFVST
;; puts out a hunk with a computed value in the CDR which sill
;; be the value of VECTOR-CLASS if it exists.
;(DEFMETHOD* (USERATOMS-HOOK VECTOR-CLASS) (self)
; (list `(TO-VECTOR ',(to-list self))))
(defmethod* (DESCRIBE VECTOR-CLASS) (ob stream level)
(declare (special SI:DESCRIBE-MAX-LEVEL))
(if (and (not (> level SI:DESCRIBE-MAX-LEVEL))
(vectorp ob))
(format stream
"~%~vTThe vector ~S has ~D elements."
level ob (vector-length ob))))
(and (status status VECTOR)
(sstatus VECTOR (list (get 'VECTORP 'SUBR)
(get 'VECTOR-LENGTH 'SUBR)
(get 'VREF 'SUBR))))

202
src/nilcom/backq.53 Executable file
View File

@@ -0,0 +1,202 @@
;;; BACKQ -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** MacLISP ****** BACKQuote reader macro function ********************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
;;; NOTE WELL TWO WARNINGS:
;;; 1) comma is defined as a readmacro character all the time,
;;; not just within BACKQUOTE
;;; 2) A flag is noticed, "BACKQUOTE-EXPAND-WHEN", which if not set to
;;; "READ" will cause the ` readmacro to produce a highly-macroified
;;; program which GRINDEF can parse and print out exactly as read-in.
(herald BACKQ /53)
(include ((lisp) subload lsp))
#-NIL
(eval-when (eval compile)
(subload SHARPCONDITIONALS)
(subload VECTOR)
)
(eval-when (compile)
(setq DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () )
)
(defmacro /`SUB-READ (&rest x)
;In order to "bootstrap"-read this file, we must start out using
; maclisp's old reader - when it is fully in, then the definition
; of /`SUB-READ is changed to be SUB-READ
#-NIL `(READ) ;standard MacLISP case
#+NIL (progn
#-MacLISP `(SUB-READ ,.x) ;standard NIL case
#+MacLISP `(OLD-READ) ;bootstrap case, with NILAID
))
(declare (special BACKQUOTE-EXPAND-WHEN |`-,-level/||)
(*expr |+ibx-qsequence/|| |+ibx-pairs/||))
#M
(declare (*fexpr READMACROINVERSE) (special |+ibx-vecp/|| |+ibx-uhunkp/||))
#-Lispm
(declare (own-symbol |`-expander/|| |`,/|| |`,@/|| |`,./||))
#-NIL
(defmacro TYPECASEQ (&rest w)
`(CASEQ (TYPEP ,(car w))
,.(mapcar '(lambda (x) (cons (sublis '((PAIR . LIST)) (car x))
(cdr x)))
(cdr w))))
;;; Readmacro function for backquote
(defun |+INTERNAL-`-macro/|| #-NIL () #N (C S)
#N (and (not (eq s READ-STREAM)) (reader-error s))
(let* ((|`-,-level/|| (1+ |`-,-level/||))
(form (cons '|`-expander/|| (/`sub-read () read-stream)) ))
(cond ((or (eq BACKQUOTE-EXPAND-WHEN 'READ)
(and (memq BACKQUOTE-EXPAND-WHEN '(EVAL COMPILE))
(memq COMPILER-STATE '(MAKLAP COMPILE DECLARE))))
(macroexpand form))
('T form))))
;;; Readmacro function for comma
(defun |+INTERNAL-,-macro/|| #-NIL () #N (C S)
#N (and (not (eq s READ-STREAM)) (reader-error s))
(and (< |`-,-level/|| 1)
(ERROR '|Comma not inside backquote, or too many commas|))
(let ((|`-,-level/|| (1- |`-,-level/||)))
(cons (caseq (tyipeek)
(#/@ (tyi) '|`,@/||)
(#/. (tyi) '|`,./||)
(T '|`,/||))
(/`sub-read () read-stream))))
;; Internal backquote expander function
(defun |+ibx/|| (x)
(cond ((null x) ''() )
((typecaseq x
(PAIR (|+ibx-pairs/|| x))
#N ((VECTOR VECTOR-S) (|+ibx-qsequence/|| x 'VECTOR))
;; ###### Here we could extend it for STRUCTures
#N (EXTEND (|+ibx-qsequence/|| x 'EXTEND))
;; ###### Add code here for LISPM and MULTICS vectors!
(T (cond
#M ((hunkp x)
(cond ((and |+ibx-vecp/|| (vectorp x))
;;Real NIL vectors are atoms, but in MacLISP ?
(|+ibx-qsequence/|| x 'VECTOR))
((and |+ibx-uhunkp/||
(funcall |+ibx-uhunkp/|| x))
;; Well, What do we do with random usrhunks?
(list 'QUOTE x))
((|+ibx-qsequence/|| x 'HUNK))))
('T (list 'QUOTE x))))))))
(defun |+ibx-pairs/|| (x)
(cond ((eq (car x) '|`,/||) (cdr x)) ;Found ",<mumble>"
((eq (car x) '|`-expander/||) ;Recursive ` instance, so
(setq x (macroexpand x)) ; expand the inner one. And
(|+ibx/|| X)) ; now for this level!
((let ((a (car x)) (d (cdr x)) d-is-pairp dqp)
;;Otherwise look at car and cdr
(if (or (memq a '(|`,./|| |`,@/||))
(memq (car d) '(|`,./|| |`,@/||)))
(error '|",@" or ",." in illegal context| x))
(cond ((and (pairp a) (memq (car a) '(|`,./|| |`,@/||)))
;;Found ",@<mumble>" or ",.<mumble>"
(setq d-is-pairp (pairp (setq d (|+ibx/|| d))))
(cond ((and d-is-pairp
(eq (car d) 'QUOTE)
(eq (cadr d) '() ))
(cdr a))
('T (setq dqp (if (eq (car a) '|`,@/||)
'APPEND
'NCONC) ;else |`,./||
a (cdr a))
;; (NCONC a (NCONC ...)) ==> (NCONC a ...)
(cond ((and d-is-pairp (eq (car d) dqp))
(list* dqp a (cdr d)))
((list dqp a d))))))
('T (setq a (|+ibx/|| a))
;;Standard case is to Tack-To-Front by (CONS A ...)
(setq d-is-pairp (pairp (setq d (|+ibx/|| d)))
dqp (and d-is-pairp (eq (car d) 'QUOTE)))
(cond ((and dqp (pairp a) (eq (car a) 'QUOTE))
(list 'QUOTE (cons (cadr a) (cadr d))))
((and dqp (eq (cadr d) '() ))
(list 'LIST a))
((and d-is-pairp (memq (car d) '(LIST LIST*)))
(list* (car d) a (cdr d)))
((list 'LIST* a d)))))))))
(defun |+ibx-qsequence/|| (x constructor-name)
(do ((i (1- (caseq constructor-name
(VECTOR (vector-length x))
#M (HUNK (hunksize x))
#N (EXTEND (error '|+ibx-qsequence/||)) ))
(1- i))
(z) (element) (constructp))
((< i 0)
(cond (constructp
#M (if (eq constructor-name 'HUNK)
(setq z (nconc (cdr z) (list (car z)))))
(cons constructor-name z))
('T (list 'QUOTE x))))
(declare (fixnum i))
(setq element (caseq constructor-name
(VECTOR (vref x i))
#M (HUNK (cxr i x))
#N (T (si:xref x i)) ))
(push (setq element (|+ibx/|| element)) z)
;;If no expanded element of the vector is 'evaluable' then it is fully
;; "quotified", and we don't need to construct it up.
(and element
(typecaseq element
(PAIR (not (eq (car element) 'QUOTE)))
(SYMBOL 'T))
(setq constructp 'T))))
;;;; MACRO to do the "compilation" into LISP code of the read-in form
(eval-when (compile)
(setq DEFMACRO-FOR-COMPILING 'T
DEFMACRO-DISPLACE-CALL MACROEXPANDED )
)
#M (def-or-autoloadable FLUSH-MACROMEMOS DEFMAX)
(defun |+INTERNAL-macro-loser/|| (Y)
(ERROR '| -- Internal 'comma' marker found outside 'backquote' context| Y))
;; merely caches the value of (status status USRHUNK) for |`-expander/||
#M (setq |+INTERNAL-macro-loser/|| (status status USRHUNK))
(defmacro |`-expander/|| (&rest x)
(declare (special |+INTERNAL-macro-loser/||))
#-MacLISP
(|+ibx/|| x)
#+MacLISP
(let* ((|+ibx-uhunkp/|| (if |+INTERNAL-macro-loser/|| (status USRHUNK)))
(|+ibx-vecp/|| (and |+ibx-uhunkp/|| (get 'VECTOR 'VERSION))))
(|+ibx/|| X))
)
(mapc '(lambda (x) (putprop x '|+INTERNAL-`-grindmacros/|| 'GRINDMACRO))
'(|`-expander/|| |`,/|| |`,@/|| |`,./|| ))
#M (setq |+ibx-vecp/|| () )
(setq |`-,-level/|| 0)
(setq-if-unbound BACKQUOTE-EXPAND-WHEN 'EVAL)

835
src/nilcom/defmac.166 Executable file
View File

@@ -0,0 +1,835 @@
;;; DEFMAC -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *****************************************************************
;;; ***** NIL ******** DEFUN& and DEFMACRO **************************
;;; *****************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *****
;;; *****************************************************************
(herald DEFMACRO /166)
#-NIL (include ((lisp) subload lsp))
#-NIL (eval-when (eval compile)
(subload SHARPCONDITIONALS)
)
#-NIL
(eval-when (eval load compile)
(subload DEFMAX)
(subload MACAID)
(subload CNVD)
)
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "DEFUN&")
(globalize "DEFUN&-CHECK-ARGS")
(globalize "DEFMACRO")
(globalize "DEFMACRO-DISPLACE")
(globalize "LET")
(globalize "LET*")
(globalize "DESETQ"))
;; This OWN-SYMBOL declaration is here so that it is easy to change
;; the number of arguments; also prevents the spurious error messages.
#+(local MacLISP)
(declare
(own-symbol DEFUN& |defmacro-1/|| |&r-l/|| DEFMACRO DEFMACRO-DISPLACE)
(defprop MACRO T 'SKIP-WARNING)
(*expr STRINGP))
#M (progn 'compile
(defvar |&r-l/|| 'LISTIFY
"Default meaning for &REST")
(defvar |&restv-ify/|| ()
"How to make rest vector.")
(defvar SI:SELF-BIND-CONS ()
"Communicates information to function about need to use BOUNDP")
(declare (mapex 'T)
(*expr SI:SELF-BIND-CONS |&r-l/|| ))
)
(defvar DEFUN&-CHECK-ARGS ()
"Should DEFUN& output code to check number of args?")
(DECLARE (*EXPR DEFUN&-ERROR)
(SPECIAL DEFUN&-ERROR)
(SPECIAL BAD-VARS BOUND-VARS ALL-LOCALS SUPPLIEDP-VARS
|&complrp/|| |&specvars/||))
(declare (special DEFMACRO-DISPLACE-CALL ;User-settable switches.
DEFMACRO-FOR-COMPILING
MACRO-EXPANSION-USE
GRIND-MACROEXPANDED ))
(declare (*expr MACROMEMO MACROFETCH |forget-macromemos/|| FLUSH-MACROMEMOS)
(special MACROMEMO MACROEXPANDED
FLUSH-MACROMEMOS DEFMAX-COUNTER-VARIABLES))
(defun (DEFUNP macro) (X) (DEFUN&-aux/| x 'T))
(defun (DEFUN& macro) (X) (DEFUN&-aux/| x () ))
(DEFUN |def-decl-comment?/|| (BODY FORM)
"Process a DEFUN/DEFMACRO body for initial documentation strings
and/or local DECLAREs."
(LET (USERCOMMENT? DECLARE?)
(OR (PAIRP BODY) (ERROR '|Bad code-body for definition| FORM))
(AND (PAIRP (CAR BODY))
(EQ (CAAR BODY) 'DECLARE)
(POP BODY DECLARE?))
(AND #+(or LISPM (and NIL (not MACLISP)))
(STRINGP (CAR BODY))
#-(or LISPM (and NIL (not MACLISP)))
(COND ((OR (NULL (CAR BODY)) (PAIRP (CAR BODY)))
() )
((SYMBOLP (CAR BODY))
(GET (CAR BODY) '+INTERNAL-STRING-MARKER))
((AND (GET 'STRINGP 'SUBR) (STRINGP (CAR BODY)))))
(POP BODY USERCOMMENT?))
(AND (PAIRP (CAR BODY))
(EQ (CAAR BODY) 'DECLARE)
(POP BODY DECLARE?))
(VALUES BODY
(IF DECLARE? (LIST DECLARE?))
(IF USERCOMMENT? (LIST USERCOMMENT?)))))
(defun |&kwp/|| (varlist more)
"Look for a keyword -- the &rest variety are assumed"
(do ((l varlist (cdr l))
(word))
((null l) () )
(setq word (car l))
(if (or (memq word '(&REST &RESTL &RESTV))
(memq word more))
(return l))))
;;;; DEFUN& for non-MacLISP
#-MacLISP (progn 'compile
(DEFUN DEFUN&-aux/| (X DEFUNPP)
(PROG (NAME VARLIST BODY DEFUN&-ERROR DECLS KEYWORDP LETLIST
ALLFLATS INSETQS BOUND-VARS BAD-VARS ALL-LOCALS KEYWORDS
IVARLIST VARL TMPVAR LAMVAR TEM SUPPLIEDP-VAR USERCOMMENT?)
(DECLARE (SPECIAL ALL-LOCALS BOUND-VARS BAD-VARS))
(SETQ X (CDR X) NAME (CAR X) IVARLIST (SETQ DEFUN&-ERROR (CADR X))
BODY (CDDR X))
(AND (NOT (ATOM NAME)) (SETQ NAME (CAR NAME)))
(COND ((EQ IVARLIST 'EXPR)
(SETQ IVARLIST (CAR BODY) BODY (CDR BODY)))
((MEMQ IVARLIST '(MACRO FEXPR))
(ERROR '|Can't DEFUN& for FEXPR or MACRO| (CONS 'DEFUN X)))
((AND IVARLIST (OR (ATOM IVARLIST) (CDR (LAST IVARLIST))))
(DEFUN&-ERROR)))
(MULTIPLE-VALUE (BODY DECLS USERCOMMENT?)
(|def-decl-comment?/|| BODY X))
(COND
((NOT DEFUNPP)
(DO VARL IVARLIST (CDR VARL) (NULL VARL)
(COND ((ATOM (CAR VARL))
(OR (SYMBOLP (CAR VARL)) (DEFUN&-ERROR))
(COND ((MEMQ (CAR VARL)
'(&AUX &OPTIONAL &REST &RESTL &RESTV))
(SETQ KEYWORDP (CAR VARL))
(AND (COND ((MEMQ KEYWORDP KEYWORDS))
((EQ KEYWORDP '&OPTIONAL)
(PUSH '&OPTIONAL KEYWORDS)
(|&kwp/|| KEYWORDS '(&AUX &OPTIONAL)))
((MEMQ KEYWORDP '(&REST &RESTL &RESTV))
(PUSH '&REST KEYWORDS)
(|&kwp/|| KEYWORDS () ))
('T (PUSH '&AUX KEYWORDS) ))
(DEFUN&-ERROR)))
('T (PUSH (CAR VARL) BAD-VARS)))
(COND ((EQ KEYWORDP '&AUX)
(AND (NOT (EQ (CAR VARL) '&AUX))
(PUSH (CAR VARL) LETLIST)))
('T (PUSH (CAR VARL) VARLIST))))
((NOT KEYWORDP)
;case of required argument with destructuring
(SETQ BAD-VARS (FLATTEN-SYMS (CAR VARL) BAD-VARS))
(si:gen-local-var TMPVAR "Reqd-Var")
(PUSH `(,(car varl) ,tmpvar) LETLIST)
(PUSH TMPVAR VARLIST))
('T (SETQ TMPVAR
(COND
((ATOM (CAAR VARL))
(OR (SYMBOLP (SETQ TMPVAR (CAAR VARL)))
(DEFUN&-ERROR))
(PUSH (SETQ LAMVAR (CAAR VARL)) BAD-VARS)
() )
('T (SETQ BAD-VARS (FLATTEN-SYMS (CAAR VARL)
BAD-VARS))
(si:gen-local-var LAMVAR "&var"))))
(COND ((AND (CDAR VARL)
(NOT (EQ (CADAR VARL) LAMVAR))
(NOT (|Certify-no-var-dependency/|| (CADAR VARL))))
(SETQ ALLFLATS (FLATTEN-SYMS (CAAR VARL) ALLFLATS))
(SETQ TEM `(DESETQ ,(caar varl)
,(or tmpvar (cadar varl))))
(COND ((SETQ SUPPLIEDP-VAR (CADDAR VARL))
(OR (SYMBOLP SUPPLIEDP-VAR)
(DEFUN&-ERROR)))
('T (si:gen-local-var SUPPLIEDP-VAR "Supplied-P")))
(PUSH (COND ((EQ KEYWORDP '&OPTIONAL)
`(OR ,suppliedp-var ,tem))
(TEM))
INSETQS)
(OR (EQ KEYWORDP '&AUX)
(PUSH `(,lamvar () ,suppliedp-var) VARLIST)))
((EQ KEYWORDP '&AUX) (PUSH (CAR VARL) LETLIST))
('T (AND TMPVAR
(PUSH `(,(caar varl) ,tmpvar) LETLIST))
(PUSH `(,lamvar ,. (cdar varl)) VARLIST))))))
(DO ((L BAD-VARS (CDR L)))
((NULL L))
(AND (CAR L) (MEMQ (CAR L) (CDR L)) (DEFUN&-ERROR)))
(AND (OR LETLIST ALLFLATS INSETQS)
(SETQ BODY `((LET (,.(nreverse letlist) ,.allflats)
,.(nreverse insetqs)
,. body))))
(push `(COMMENT ARGLIST = ,defun&-error) body)
)
('T (SETQ BODY (REVERSE BODY))
(SETQ BODY `((PROG () ,.(nreverse (cons `(RETURN ,(car body))
(cdr body))))))))
(SETQ BODY `(,.decls ,.usercomment? ,. body))
(RETURN
(COND
(DEFUNPP `(DEFUN ,name ivarlist ,.body))
(`(FSET ',name (FUNCTION (LAMBDA ,(nreverse varlist) ,.body))))))
))
) ;end of #-MacLISP
;;;; DEFUN& for MacLISP
#M (progn 'compile
;;; A loop for going down the VARLIST and consing up forms
;;; stops when the tail is at MORE
;;; Requires some variables to be setup - MORE ARGNO
;;; Provides some variables for the body - VARL
;;; Increments ARGNO
(defun si:MAP-VL macro (x)
`(DO ((VARL VARLIST (CDR VARL))
(ANSL))
((EQ VARL MORE) ANSL)
(SETQ ARGNO (1+ ARGNO)
ANSL (NCONC ,(cadr x) ANSL))))
(DEFUN DEFUN&-aux/| (X DEFUNPP)
(LET ((DCA DEFUN&-CHECK-ARGS) (MIN 0) (MAX 262143.) (ARGNO 0)
NAME-ARG VARLIST BODY DEFUN&-ERROR SUPPLIEDP-VARS |&restv-ify/||
LEXPRVAR ALLFLATS ALLVARS MORE LETLIST DECLS INSETQS
USERCOMMENT? TMP IVARLIST)
(SETQ X (CDR X) NAME-ARG (CAR X) VARLIST (CADR X) BODY (CDDR X))
(COND ((EQ VARLIST 'EXPR) (POP BODY VARLIST))
((MEMQ VARLIST '(MACRO FEXPR))
(ERROR "Can't DEFUN& for FEXPR or MACRO"
`(DEFUN& ,name-arg ,varlist ,. body))))
(AND (SETQ DEFUN&-ERROR VARLIST) ;null varlist is ok
(OR (ATOM VARLIST) (CDR (LAST VARLIST)))
(DEFUN&-ERROR))
(SETQ IVARLIST VARLIST)
(MULTIPLE-VALUE (BODY DECLS USERCOMMENT?)
(|def-decl-comment?/|| BODY X))
(COND (DEFUNPP
(SETQ BODY (REVERSE BODY))
(SETQ BODY `((PROG () ,.(nreverse (cons `(RETURN ,(car body))
(cdr body)))))))
((let ((|&complrp/|| (status feature COMPLR))
(|&specvars/|| (mapcan #'(lambda (x)
(and (not (atom x))
(eq (car x) 'SPECIAL)
;; Forces open-coding of map
(setq tmp (cdr x))
(append tmp () )))
(cdar decls))))
(declare (special |&specvars/|| |&complrp/||))
(COND
((AND (SETQ MORE (|&kwp/|| VARLIST '(&AUX &OPTIONAL)))
(NOT (EQ (CAR MORE) '&AUX)))
(si:gen-local-var LEXPRVAR "LexprVar")
;; Initialize letlist for getting the &required vars
(SETQ LETLIST (si:MAP-VL (list `(,(car varl) (ARG ,argno))))
MIN (LENGTH LETLIST)
MAX (IF (|&kwp/|| MORE () ) ;if any &REST?
()
(+ MIN (- (LENGTH (CDR MORE))
(LENGTH (MEMQ '&AUX (CDR MORE))))))
VARLIST LEXPRVAR)
(setq
letlist
(nreconc
letlist
(multiple-value-bind (l inisets)
(if (eq (pop more tmp) '&OPTIONAL)
(|&o-l/|| MORE ARGNO LEXPRVAR)
(|&r-l/|| MORE ARGNO LEXPRVAR TMP))
(if inisets (setq insetqs (nconc inisets insetqs)))
l))))
('T (cond ((and more (eq (car more) '&AUX))
(setq varlist (but-tail varlist more))
(multiple-value (letlist insetqs)
(|&a-l/|| (cdr more)))))
(SETQ MAX (SETQ MIN (LENGTH VARLIST)))
(if (DO ((L VARLIST (CDR L)))
((NULL L))
(AND (CAR L) (NOT (SYMBOLP (CAR L))) (RETURN 'T)))
(SETQ VARLIST
(MAPCAR
#'(LAMBDA (VAR)
(COND ((OR (NULL VAR) (SYMBOLP VAR)) VAR)
('T (si:gen-local-var TMP "Reqd-Var")
(PUSH `(,var ,tmp) LETLIST)
TMP)))
VARLIST)))))
(COND (SUPPLIEDP-VARS
(SETQ ALLFLATS (NCONC (MAPCAR #'CAR SUPPLIEDP-VARS)
ALLFLATS))
(SETQ BODY (NCONC (MAPCAR
#'(LAMBDA (X)
`(AND (> ,lexprvar ,(1- (cdr x)))
(SETQ ,(caar x) 'T)))
SUPPLIEDP-VARS)
BODY)) ))
(SETQ ALLVARS (FLATTEN-SYMS (MAPCAR #'CAR LETLIST)
(IF LEXPRVAR
ALLFLATS ;VARLIST is atomic?
(FLATTEN-SYMS VARLIST ALLFLATS))))
(DO ((L ALLVARS (CDR L)))
((NULL L))
(AND (CAR L) (MEMQ (CAR L) (CDR L)) (DEFUN&-ERROR)))
(if letlist
(let ((BOUND-VARS)
(BAD-VARS ALLVARS)
(ALL-LOCALS (si:all-locals? allvars))
(insetqs-p) )
(declare (special BAD-VARS BOUND-VARS ALL-LOCALS))
(DO ((L LETLIST (CDR L)) (selfp () () ))
((NULL L))
;;Analyze variable dependencies in left-to-right
;; view of default values for &optionals and &auxs
(COND ((AND (CDAR L)
(IF (ATOM (SETQ TMP (CADAR L)))
(NOT (EQ TMP (CAAR L)))
(NOT (setq selfp (EQ (CAR TMP) 'SI:SELF-BIND))))
(COND (LEXPRVAR) ;VARLIST is atomic?
((SYMBOLP TMP)
(NOT (MEMQ TMP VARLIST)))
('T))
(NOT (|Certify-no-var-dependency/|| TMP)))
(SETQ INSETQS-P 'T)
(SETQ ALLFLATS (FLATTEN-SYMS (CAAR L) ALLFLATS))
(PUSH `(DESETQ ,(caar l) ,(cadar l)) INSETQS)
(RPLACA L () ))
(selfp (rplaca (cdar l) (macroexpand tmp)))))
(AND INSETQS-P (SETQ LETLIST (DELQ () LETLIST)))))
(COND ((OR ALLFLATS LETLIST)
(SETQ BODY `((LET (,.letlist ,.allflats)
,.(nreverse insetqs)
,. body)))))
(COND ((AND DCA LEXPRVAR (OR MAX (NOT (= 0 MIN))))
;;If wrong number of arguments, enter an error handler.
;;A form may be returned so eval it and return as
;; value of function.
(LET ((MSG)
(PREDICATE)
(CHECKARGS `(LIST (CONS ',name-arg (LISTIFY ,lexprvar))
',defun&-error)))
(COND
((AND MAX (NOT (= 0 MIN)))
(SETQ MSG `(COND ((> ,lexprvar ,max)
'|Too many arguments supplied |)
('|Too few arguments supplied |)))
(SETQ PREDICATE
(if (= MAX MIN)
`(NOT (= ,lexprvar ,max))
`(OR (< ,lexprvar ,min)
(> ,lexprvar ,max)))))
(MAX
(SETQ MSG ''|Too many arguments supplied |)
(SETQ PREDICATE `(> ,lexprvar ,max)))
((NOT (= 0 MIN))
(SETQ MSG ''|Too few arguments supplied |)
(SETQ PREDICATE `(< ,lexprvar ,min))))
(SETQ BODY
`((COND (,predicate (EVAL (ERROR ,msg
,checkargs
'WRNG-NO-ARGS)))
('T ,.body)))))))
(PUSH `(COMMENT ARGLIST = ,defun&-error) BODY))))
(SETQ BODY `(DEFUN ,name-arg ,varlist
,.decls
,.usercomment?
,.body))
;;If DEFUN&-CHECK-ARGS is NIL, then let APPLY check the number
;; of args via the ARGS mechanism.
(and (cond ((and lexprvar (symbolp name-arg))
(setq tmp `((ARGS ',name-arg '(,min . ,(or max 510.)))))
'T)
(|&restv-ify/|| (setq tmp () ) 'T))
(setq body `(PROGN 'COMPILE
,@|&restv-ify/||
,body
,.tmp )))
BODY))
;;;; Helper Funs for MacLISP DEFUN&
;;; Process a varlist that follows an &OPTIONAL.
;;; The remainder may have an &REST and/or and &AUX.
;;; ARGNO is one less than the index number of the argument at
;;; the first of the list
;;;Returns: 1st value is an item for the LETLIST,
;;; 2nd value is an allflats list
;;; 3rd value is an INSETQS list (in case some bindings 'depended')
(defun |&o-l/|| (varlist argno lexprvar)
(let ((more (|&kwp/|| varlist '(&AUX &OPTIONAL)))
suppliedpp tmp insetqs)
(if (eq (car more) '&OPTIONAL) (DEFUN&-ERROR))
(values
(nreconc
(si:MAP-VL
(cond
((symbolp (car varl))
(list `(,(car varl)
(AND (> ,lexprvar ,(1- argno)) (ARG ,argno)))))
((cond ((prog2 (setq suppliedpp () ) (atom (car varl))))
((atom (cdar varl)) (cdar varl))
((atom (setq suppliedpp (cddar varl))) suppliedpp)
((or (cdr suppliedpp)
(null (car suppliedpp))
(not (symbolp (car suppliedpp))))))
(DEFUN&-ERROR))
('T (if suppliedpp
(push (cons suppliedpp ARGNO) SUPPLIEDP-VARS))
(multiple-value-bind (l desetqer)
(si:bind-doublet-now? (caar varl)
(cadar varl)
'T
lexprvar
argno)
(if desetqer (push desetqer insetqs))
l))))
(if more
(multiple-value-bind (l desetqer)
(if (eq (pop more tmp) '&AUX)
(|&a-l/|| more)
(|&r-l/|| MORE ARGNO LEXPRVAR TMP))
(if desetqer (setq insetqs (nconc desetqer insetqs)))
l)))
insetqs)))
;;;Produce a list of the form (<var-spec> <form-to-eval>) if there is no
;;; variable in the <var-spec> which appears in <form-to-eval>.
;;;Otherwise, have to substitute for <form-to-eval>, and cons up a desetqer
;;; for the INSETQS list, and return possibly a list of several pairs.
(defun SI:BIND-DOUBLET-NOW? (var-spec val optp lexprvar argno)
(let ((retval (if (null optp)
val
`(COND ((> ,lexprvar ,(1- argno)) (ARG ,argno))
('T ,val))))
(SI:SELF-BIND-CONS () )
desetqer )
(values
(cond ((cond ((atom val)
(cond ((atom var-spec)
(cond ((eq val var-spec)
(setq SI:SELF-BIND-CONS '(T))
() )
('T)))
((or (not (symbolp val))
(not (memq val (flatten-syms var-spec () ))))
;;Permits things like "&optional (A 3) &aux (B B)"
'T)))
((not (symbolp (car val))) () )
((memq (car val) '(QUOTE FUNCTION)))
((let* ((BOUND-VARS () )
(BAD-VARS (if (atom var-spec)
(list var-spec)
(flatten-syms var-spec () )))
(ALL-LOCALS (si:all-locals? BAD-VARS)))
(declare (special BAD-VARS ALL-LOCALS BOUND-VARS))
(|Certify-no-var-dependency/|| val))))
`((,var-spec ,retval)))
('T (setq desetqer `(DESETQ ,var-spec ,retval))
(if (atom var-spec)
(si:self-bind-cons var-spec)
(mapcan #'SI:SELF-BIND-CONS (flatten-syms var-spec () )))))
desetqer)))
(defun SI:ALL-LOCALS? (varsl)
(declare (special |&specvars/|| |&complrp/||))
(do ((l varsl (cdr l))
(var))
((null l) 'T)
(and (symbolp (setq var (car l)))
(or (memq var |&specvars/||)
(if |&complrp/||
(specialp var)
(get var 'SPECIAL)))
(return () ))))
;;;###### Someday, we could drop the BOUNDP check in SI:SELF-BIND if the last
;;; line just above would split the flattend-syms into two lists --
;;; 1: vars which are needed to evaluate the val
;;; 2: remainder
;;;Thus, in "&optional ((a . b) (mumble a))" would need to bind 'a' to
;;; itself, but b could still be bound to ().
(defun SI:SELF-BIND-CONS (var)
(list `(,var (SI:SELF-BIND ,var ,.si:self-bind-cons))))
(defun (SI:SELF-BIND macro) (x)
(let (((() var no-boundp-check?) x))
(if no-boundp-check?
var
`(AND (BOUNDP ',var) ,var))))
;;; Process a varlist that follows an &AUX.
(defun |&a-l/|| (varlist)
(let (l insetqs desetqer)
(if (|&kwp/|| varlist '(&OPTIONAL)) (DEFUN&-ERROR))
(if (memq '&AUX varlist)
(setq varlist (delq '&AUX (append varlist () ))))
(values (mapcan
#'(lambda (var)
(if (atom var)
(if (symbolp var)
(list `(,var () ))
(DEFUN&-ERROR))
(multiple-value
(l desetqer)
(si:bind-doublet-now? (car var) (cadr var) () () () ))
(if desetqer (push desetqer insetqs))
l))
varlist)
insetqs)))
;;; Process a varlist that follows a member of the &REST family.
;;; ARGNO is one less than the index number of argument at the head of the list
;;; RESTIFY is one of &REST, &RESTV, or &RESTL. We make the apropriate
;;; selection of the LISTIFY or |&restv-ify/||. If it's &REST, the value of
;;; |&r-l/|| is selected.
(DEFUN |&r-l/|| (VARLIST ARGNO LEXPRVAR RESTIFY)
(AND (OR (NOT (SYMBOLP (CAR VARLIST)))
(|&kwp/|| VARLIST '(&OPTIONAL))
(EQ (CAR VARLIST) '&AUX) )
(DEFUN&-ERROR))
(SETQ RESTIFY
(CASEQ RESTIFY
(&REST |&r-l/||)
(&RESTL 'LISTIFY)
(&RESTV '|&restv-ify/||)))
(IF (EQ RESTIFY '|&restv-ify/||) ;Signal this case! May have to
(SETQ |&restv-ify/|| ; output a putprop for autoloading
'(#%(def-or-autoloadable |&restv-ify/|| VECTOR))))
(SETQ ARGNO (IF (= ARGNO 0)
`(,restify ,lexprvar) ;restify may = LISTIFY
`(AND (> ,lexprvar ,argno)
(,restify (- ,argno ,lexprvar)))))
(SETQ LEXPRVAR (COND ((NULL (CDR VARLIST)) () )
((EQ (CADR VARLIST) '&AUX) (|&a-l/|| (CDDR VARLIST)))
((DEFUN&-ERROR))) )
(IF (CAR VARLIST)
(CONS `(,(car varlist) ,argno) LEXPRVAR)
LEXPRVAR))
) ;end of #M
;;;; Helper Functions
#Q (defun (PAIRP macro) (x) `(NOT (ATOM ,(cadr x))))
(defun DEFUN&-ERROR ()
(error '|Bad variable-list syntax -- DEFUN& | DEFUN&-ERROR))
#M (def-or-autoloadable BUT-TAIL MACAID)
#M (def-or-autoloadable |Certify-no-var-dependency/|| CNVD)
;;;; DEFMACRO and MACRO
;;Actual macro functions not defined until after this common subr is defined
(DEFUN |defmacro-1/|| (X DDC)
(DECLARE (SPECIAL MACROS))
(LET (((NAME-ARG DEF-ARGLIST . BODY) X)
(MIN 0) (MAX 262143.)
;; Foo! the following kludgerous crap is here becauses CWH
;; is too cowardly to introduce the variable DEFMACRO-FOR-COMPILING
;; into the multics lisp compiler; foo on CWH -- 3/15/81
(DFC (COND ((BOUNDP 'DEFMACRO-FOR-COMPILING)
DEFMACRO-FOR-COMPILING)
((STATUS FEATURE COMPLR)
MACROS)
('T)))
(DCA DEFMACRO-CHECK-ARGS)
DECLARE? USERCOMMENT? ARGLIST-COMMENT?
RESTARGP WHOLEP DEFAULTOPTSP
NAME ARGLIST MACROARG OPT-ARGLIST OPT-INISL RESTARG
AUXVARS AUX-INISL ALLFLATS ARGSCHECK SEQUENCER TEM BADP )
(MULTIPLE-VALUE (BODY DECLARE? USERCOMMENT?)
(|def-decl-comment?/|| BODY X))
(COND ((SYMBOLP NAME-ARG) (SETQ NAME NAME-ARG))
('T (SETQ NAME (CAR NAME-ARG))
(OR (SYMBOLP NAME) (SETQ BADP 'T NAME 'FOO))
(AND (SETQ TEM (GETL NAME-ARG '(DEFMACRO-CHECK-ARGS)))
(SETQ DCA (EVAL (CADR TEM))))
(AND (SETQ TEM (GETL NAME-ARG '(DEFMACRO-DISPLACE-CALL)))
(SETQ DDC (EVAL (CADR TEM))))
(SETQ TEM (GETL NAME-ARG '(DEFMACRO-FOR-COMPILING)))
(SETQ NAME-ARG
#-LISPM
(COND ((NULL TEM) NAME)
('T (SETQ DFC (AND (EVAL (CADR TEM)) 'T))
`(,name DEFMACRO-FOR-COMPILING ,dfc )))
#+LISPM
(PROG2 (EVAL (CADR TEM)) NAME)) ))
(si:gen-local-var MACROARG (symbolconc name '/-MACROARG))
(SETQ ARGLIST
(COND ;Next two clauses permit forms like "(DEFMACRO FOO X ...)"
; and "(DEFMACRO FOO (<various-args> . X) ...)"
((ATOM DEF-ARGLIST) `(&REST ,def-arglist))
((CDR (SETQ TEM (LAST DEF-ARGLIST)))
`(,.(but-tail def-arglist tem) ,(car tem) &REST
,(cdr tem)))
('T DEF-ARGLIST)))
;Process a "&WHOLE" argument, if present
(COND ((SETQ TEM (MEMQ '&WHOLE ARGLIST))
(COND ((OR (ATOM (CDR TEM))
(MEMQ (CADR TEM) '(&AUX &OPTIONAL &REST &BODY &WHOLE)))
(SETQ BADP 'T))
('T (SETQ ARGLIST (NCONC (BUT-TAIL ARGLIST TEM)
(CDDR TEM)))
(AND (NULL ARGLIST) (SETQ DCA () ))
(COND ((NULL (CADR TEM)) () )
((NOT (SYMBOLP (CADR TEM)))
(COND ((PAIRP (CADR TEM))
(SETQ ALLFLATS (FLATTEN-SYMS (CADR TEM)
ALLFLATS)
AUX-INISL `((DESETQ ,(cadr tem)
,macroarg))))
('T (SETQ BADP 'T))))
('T (SETQ MACROARG (CADR TEM))))))
(OR BADP (SETQ WHOLEP 'T))))
;Process "&AUX" arguments, if present
(COND ((SETQ TEM (MEMQ '&AUX ARGLIST))
(SETQ ARGLIST (BUT-TAIL ARGLIST TEM)
AUXVARS (CDR TEM))
(IF (MEMQ '&AUX AUXVARS)
(SETQ AUXVARS (DELQ '&AUX (APPEND AUXVARS () ))))
(MAPC #'(LAMBDA (X)
(SETQ ALLFLATS
(COND ((ATOM X)
(IF (MEMQ X '(&OPTIONAL &REST &BODY))
(SETQ BADP 'T))
(CONS X ALLFLATS))
('T (PUSH `(DESETQ ,(car x) ,(cadr x))
AUX-INISL)
(FLATTEN-SYMS (CAR X) ALLFLATS)))))
AUXVARS)
(SETQ AUX-INISL (NREVERSE AUX-INISL))))
;Process any &OPTIONAL and &REST arguments
(COND ((SETQ TEM (COND ((MEMQ '&OPTIONAL ARGLIST))
((SETQ RESTARGP (OR (MEMQ '&REST ARGLIST)
(MEMQ '&BODY ARGLIST))))))
(SETQ ARGLIST (BUT-TAIL ARGLIST TEM)
MIN (LENGTH ARGLIST))
(COND (RESTARGP
(SETQ RESTARG (CADR RESTARGP))
(AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
(CDDR RESTARGP))
(SETQ BADP 'T)))
('T ;so (EQ (CAR TEM) '&OPTIONAL)
(SETQ OPT-ARGLIST (CDR TEM))
(COND ((MEMQ '&OPTIONAL OPT-ARGLIST) (SETQ BADP 'T))
((SETQ RESTARGP (OR (MEMQ '&REST OPT-ARGLIST)
(MEMQ '&BODY OPT-ARGLIST)))
(SETQ OPT-ARGLIST (BUT-TAIL OPT-ARGLIST
RESTARGP))
(SETQ RESTARG (CADR RESTARGP))
(AND (OR (AND RESTARG (NOT (SYMBOLP RESTARG)))
(CDDR RESTARGP))
(SETQ BADP 'T)))
('T (SETQ MAX (+ MIN (LENGTH OPT-ARGLIST)))))
(SETQ OPT-ARGLIST
(MAPCAR
#'(LAMBDA (X)
(COND
((OR (NULL X) (SYMBOLP X))
(PUSH () OPT-INISL)
X)
('T (SETQ DEFAULTOPTSP 'T)
(AND
(COND ((AND (CDR X) (ATOM (CDR X))))
((NULL (CDDR X)) () )
((OR (ATOM (CDDR X))
(NOT (SYMBOLP (CADDR X)))))
('T ; Find the "suppliedp" var
(PUSH (CADDR X) ALLFLATS)
(CDDDR X)))
(SETQ BADP 'T))
;((A . B) (MUMBLEIFY)) so find A & B
(SETQ ALLFLATS (FLATTEN-SYMS
(CAR X)
ALLFLATS))
(PUSH X OPT-INISL)
() )))
OPT-ARGLIST))) )
(SETQ ARGLIST (APPEND ARGLIST OPT-ARGLIST RESTARG)))
('T (SETQ MIN (SETQ MAX (LENGTH ARGLIST)))))
(DO ((L (FLATTEN-SYMS ARGLIST ALLFLATS) (CDR L)))
((NULL L))
(AND (CAR L) (MEMQ (CAR L) (CDR L)) (SETQ BADP 'T)))
(IF BADP (ERROR '|Bad arg pattern in use of DEFMACRO| `(DEFMACRO ,x)))
(COND ((NOT DCA))
((AND (= MIN 0) (= MAX 262143.)))
((= MIN MAX) (SETQ ARGSCHECK `(= (LENGTH ,macroarg) ,(1+ min))))
('T (AND (NOT (= MIN 0))
(SETQ ARGSCHECK `(NOT (< (LENGTH ,macroarg) ,(1+ min)))))
(COND ((= MAX 262143.))
('T (SETQ TEM `(NOT (> (LENGTH ,macroarg) ,(1+ max))))
(SETQ ARGSCHECK (COND ((NULL ARGSCHECK) TEM)
(`(AND ,argscheck ,tem))))))))
(IF ARGSCHECK (SETQ ARGSCHECK `((AND (NOT ,argscheck)
(ERROR '|Wrong number args for macro|
,macroarg)))))
(COND
((NOT (AND OPT-ARGLIST DEFAULTOPTSP)) (SETQ OPT-INISL () ))
('T (SETQ SEQUENCER (si:gen-local-var () "MacArgL")
OPT-INISL (MAPCAN
#'(LAMBDA (X)
`((SETQ ,sequencer (CDR ,sequencer))
,.(and x `((DESETQ
,(car x)
(COND (,sequencer
,.(if (cddr x) `((SETQ ,(caddr x) 'T)))
(CAR ,sequencer))
(,(cadr x))))))))
;; OPT-INISL is currently in reverse order.
;; CDR it until something non-null shows up.
(DO ((L OPT-INISL (CDR L)))
((OR (NULL L) (NOT (NULL (CAR L))))
L))))
(SETQ OPT-INISL (NREVERSE (CDR OPT-INISL)))
(PUSH `(SETQ ,sequencer ,(cond ((= min 0) `(CDR ,macroarg))
(`(NTHCDR (1+ ,min) ,macroarg))))
OPT-INISL)
(PUSH SEQUENCER ALLFLATS)))
(COND ((AND (ATOM ARGLIST) ;(), or RESTARG
(OR (NULL ARGLIST) (NULL ARGSCHECK))
(NULL ALLFLATS)
(NULL AUX-INISL)
(NULL OPT-INISL) )
(PUSH (COND ((NULL ARGLIST)
(COND ((OR (NULL DCA) RESTARGP) MACROARG)
(`(AND (CDR ,macroarg)
(ERROR '|No args allowed for this macro|
,macroarg)))) )
('T (AND (NOT (EQ ARGLIST RESTARG))
(+INTERNAL-LOSSAGE '&REST
'DEFMACRO
(LIST ARGLIST RESTARG)))
(SETQ MACROARG ARGLIST)
;; A simple case - "(DEFMACRO FOO X (doit X))"
`(SETQ ,macroarg (CDR ,macroarg))))
BODY))
('T (SETQ ARGLIST-COMMENT?
`((COMMENT ARGLIST = ,def-arglist))
BODY `(,.argscheck
(LET ((,arglist (CDR ,macroarg)) ,.allflats)
,.opt-inisl
,.aux-inisl
,. body)))))
(IF DDC (SETQ BODY (COND ((EQ DDC 'DEFMACRO-DISPLACE)
`((DISPLACE ,macroarg (PROGN ,. body))))
(`((OR (MACROFETCH ,macroarg)
(MACROMEMO ,macroarg
(PROGN ,. body)
',name)))))))
(SETQ BODY `(MACRO ,name-arg (,macroarg)
,.declare?
,.usercomment?
,.arglist-comment?
,. body))
(setq ddc `(FLUSH-MACROMEMOS
',name
,(cond ((eq ddc MACROEXPANDED)
'MACROEXPANDED)
((or (null ddc) (eq ddc 'DEFMACRO-DISPLACE))
() )
((or (eq ddc 'FLUSH-MACROMEMOS)
(not (memq ddc defmax-counter-variables)))
`'FLUSH-MACROMEMOS)
( `',ddc))))
(if (and ddc (not dfc))
(setq ddc `(EVAL-WHEN (EVAL COMPILE) ,ddc)))
`(PROGN 'COMPILE ,ddc ,body)))
(defun (DEFMACRO MACRO) (x)
(|defmacro-1/||
(cdr x)
(if (boundp 'DEFMACRO-DISPLACE-CALL) DEFMACRO-DISPLACE-CALL)))
(defun (DEFMACRO-DISPLACE MACRO) (x)
(|defmacro-1/|| (CDR X) 'DEFMACRO-DISPLACE))
;;; Just for starters, consider the case of ((FIND it) 1), where
;;; FIND is a macro s.t. (FIND it) ==> FOO,
;;; NIL version of MACRO is in the "NILMAC" file.
#M
(defun (MACRO MACRO) (x)
(declare (special MACROS))
(let ((name (cadr x))
(bvl-body (cddr x))
(dfc (cond ((boundp 'DEFMACRO-FOR-COMPILING)
DEFMACRO-FOR-COMPILING)
((status FEATURE COMPLR)
MACROS)
('T)))
tem)
(cond ((not (atom name))
(setq tem (getl name '(DEFMACRO-FOR-COMPILING))
name (car name))
(and tem (setq dfc (eval (cadr tem))))))
`(DEFUN ,@(cond (dfc `((,name MACRO)))
('t `(,name MACRO)))
,. bvl-body)))

520
src/nilcom/defmax.98 Executable file
View File

@@ -0,0 +1,520 @@
;;; DEFMAX -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ************************************************************************
;;; ***** NIL ******* DEFMacro AuXilliary helpers **************************
;;; ************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ************
;;; ************************************************************************
;;; See second page for documentation
(herald DEFMAX /98)
#-NIL (include ((lisp) subload lsp))
#-NIL (eval-when (eval compile)
(subload SHARPCONDITIONALS)
)
#+(or LISPM (and NIL (not MacLISP)))
(progn 'compile
(globalize "DEFMACRO-CHECK-ARGS")
(globalize "DEFMACRO-DISPLACE-CALL")
(globalize "DEFMACRO-FOR-COMPILING")
(globalize "forget-macromemos/|")
(globalize "FLUSH-MACROMEMOS")
(globalize "defvst-construction/|")
#Q (globalize "DEFMAX-DISPLACE")
(globalize "GRIND-MACROEXPANDED")
(globalize "MACROEXPANDED-grindmacro/|")
(globalize "GRINDMACRO")
(globalize "MACRO-EXPANSION-USE")
(globalize "MACROEXPAND")
(globalize "MACROEXPAND-1*")
(globalize "MACROEXPAND-1*M")
(globalize "MACROMEMO")
(globalize "MACROFETCH")
(globalize "MACROEXPANDED")
(globalize "MACRO")
(globalize "STATIC-AREAP")
(globalize "STATIC-COPY")
(globalize "WRITEABLEP")
)
;;; Three flags controlling the macro-producing macros:
;;; DEFMACRO-DISPLACE-CALL if non-null, the resultant macros do a runtime
;;; (default = T) test of MACRO-EXPANSION-USE for possible displacement
;;; and/or "memoizing" in a hasharray. If equal to the
;;; variable MACROEXPANDED, then the "cache" for expansions
;;; of this macro need be cleared only when it is redefined
;;; DEFMACRO-FOR-COMPILING determines whether the macros produced will be
;;; (default = T) of the form that gets compiled by COMPLR
;;; (in either case, COMPLR "remembers" them).
;;; DEFMACRO-CHECK-ARGS determines whether there should be code to carry
;;; (default = T) out number-of-args checking at runtime.
;;; In the runtime environment, macros produced while
;;; DEFMACRO-DISPLACE-CALL is non-null will pay attention to the global
;;; variable MACRO-EXPANSION-USE, which if null means merely to run the
;;; code just produced, but otherwise is a function of two arguments for
;;; doing some kind of "displaceing". The user can supply his own function,
;;; or accept one of the system-supplied ones. (These particular three
;;; system functions should not be clobbered by the user since other parts
;;; of the system depend upon them). System-supplied "functions":
;;; = () - run no function, but merely expand the macro
;;; and return that value.
;;; = MACROEXPANDED - Displace the original cell with a form like
;;; (MACROEXPANDED <name>
;;; <validation-item>
;;; <original-form>
;;; <expansion>)
;;; Thereafter, the macro named MACROEXPANDED will
;;; return the <expansion> until either the value of
;;; MACRO-EXPANSION-USE changes, or <validation-item>
;;; changes (such as by redefining some macro). All
;;; such expansions can be invalidated by incrementing
;;; the global (fixnum) variable |forget-macromemos/|| .
;;; = MACROMEMO - Remember the expansions is a hasharray, where the
;;; global variable MACROMEMO is a dotted pair of the
;;; number-of-buckets and the array pointer itself.
;;; All "memorized" expansions can be forgotten merely
;;; by doing (RPLACD MACROMEMO () ).
;;; = DISPLACE - Displace the original cell with the expansion of the
;;; macro-form. There is no general way to un-do, or
;;; "go back" after this kind of displacement.
;;; Pretty-printing of forms displaced with MACROEXPANDED is controlled by
;;; the global variable GRIND-MACROEXPANDED: if T, then only the
;;; expanded form will be printed; if (), then only the original form
;;; will be printed. (Default = () )
;;;; Declarations and Initializations
#+(local MacLISP)
(declare (own-symbol
MACROFETCH MACROMEMO MACROEXPANDED |forget-macromemos/||
MACROEXPAND MACROEXPAND-1 MACROEXPAND-1* MACROEXPAND-1*M
+INTERNAL-TRY-AUTOLOADP))
(declare (special DEFMACRO-CHECK-ARGS ;These are user-settable
DEFMACRO-DISPLACE-CALL ; switches.
DEFMACRO-FOR-COMPILING
FIND-MACRO-DEFINITION
MACRO-EXPANSION-USE
MACROMEMO
MACROEXPANDED
GRIND-MACROEXPANDED )
(*expr FIND-MACRO-DEFINITION MACROMEMO MACROFETCH
|forget-macromemos/|| FLUSH-MACROMEMOS)
(special ;; records total number of macro redefinitions
FLUSH-MACROMEMOS
;; records total number of defvst redefinitions
|defvst-construction/||
;; 1+[max of DEFMAXCOUNTER-VARIABLES] when user requests
;; a flushing of all memos.
|forgetfulness-max/|| ))
#+(and MacLISP PDP10)
(progn 'COMPILE
(or (getl 'DELASSQ '(LSUBR EXPR))
(defun DELASSQ n
(and (or (< n 2) (> n 3))
(error 'WRNG-NO-ARGS (cons 'DELASSQ (listify n))))
(let ((x (arg 1))
(ll (arg 2)))
(do ((z (assq x ll) (assq x ll)))
((null z) ll)
(setq ll (delq z ll))))))
(def-or-autoloadable PUREP PUREP)
(def-or-autoloadable WRITEABLEP PUREP)
)
(eval-when (eval load compile)
(setq DEFMAX-COUNTER-VARIABLES
'(|defvst-construction/|| ;advanced at any redef of a DEFVST
FLUSH-MACROMEMOS ;advanced at any redef of a macro
))
)
(eval-when (compile)
(eval (cons 'SPECIAL DEFMAX-COUNTER-VARIABLES))
)
;; Following will set up some relevant variables, unless already
;; bound to some non-null value; certain cases will even override
;; a prior setting to null.
(let (*RSET)
(mapc '(lambda (x)
(cond ((or (not (boundp (car x)))
(null (symeval (car x)))
(caddr x))
(set (car x) (eval (cadr x))))))
'((FIND-MACRO-DEFINITION #'FIND-MACRO-DEFINITION)
(MACRO-EXPANSION-USE 'MACROEXPANDED )
(MACROEXPANDED (COPYSYMBOL 'MACROEXPANDED () ))
;Global counter, incremented when a defmacro'd macro is redefined
(FLUSH-MACROMEMOS 0)
;Global counter, incremented when a defvst'd structure is redefined
(|defvst-construction/|| 0)
;; 1+[max of COUNTER-VARIABLES] when flush-all done by user
(|forgetfulness-max/|| 0 )
;Switch to tell GRINDEF to use the original form
(GRIND-MACROEXPANDED () )
(MACROMEMO (NCONS 103.) T) ;; 27th prime!
))
)
;;;; Temporary macros
(eval-when (compile)
(setq DEFMACRO-FOR-COMPILING ()
DEFMACRO-DISPLACE-CALL ()
DEFMACRO-CHECK-ARGS () ))
;;Well, when can we take this out? -- JonL, 12/23/80
#N (progn 'compile
(defmacro STATIC-AREAP (&rest l) '() )
(defmacro STATIC-COPY (x) x)
)
#-NIL (progn 'compile
(defmacro STATIC-AREAP (x)
#+PDP10 `(PUREP ,x)
#-PDP10 '() )
(defmacro STATIC-COPY (x)
#+PDP10 `(PURCOPY ,x)
#-PDP10 '() )
(defmacro MAKE-VECTOR (n) `(*ARRAY () T ,n))
(defmacro VREF (v i) `(ARRAYCALL T ,v ,i))
(defmacro VSET (v i val) `(STORE (ARRAYCALL T ,v ,i) ,val))
(defmacro TYPECASEQ (&rest w)
`(CASEQ (TYPEP ,(car w))
,.(mapcar '(lambda (x) (cons (subst 'LIST 'PAIR (car x)) (cdr x)))
(cdr w))))
#Q ;;Pooor LISPM doesn't have a good DISPLACE
(defun DEFMAX-DISPLACE (x y)
(check-arg x LISTP "a list")
(rplacd x (cond ((atom y)
(rplaca x 'PROGN)
(list y))
('T (rplaca x (car y)) (cdr y))))
x)
)
#-LISPM
(defmacro DEFMAX-DISPLACE (&rest x) `(DISPLACE ,.x))
;;; If "MACROMEMO" is the working mode, then (CDR MACROMEMO) is a ptr
;;; to the hasharray (a "vector"). Also, if some entry couldn't be
;;; displaced properly for the MACROEXPANDED mode (such as would occur
;;; if the expr code were in pure space), then (CDR MACROMEMO) is likewise
;; setup.
;;; Note that we don't really expect to use the "MACROMEMO" mode
;;; unless the implementation can support MAKNUM efficiently.
(defmacro HASH-GET (key &optional (hash-name 'MACROMEMO))
`(ASSQ ,key (VREF (CDR ,hash-name) (\ (MAKNUM ,key) (CAR ,hash-name)))))
(defmacro HASH-PUT (x &optional (hash-name 'MACROMEMO))
`(LET* ((ENTRY ,x)
(HASHNO (\ (MAKNUM (CAR ENTRY)) (CAR ,hash-name))))
(DECLARE (FIXNUM HASHNO))
(OR (AND ,hash-name (CDR ,hash-name))
;; Initialize memo table if necessary
(RPLACD ,hash-name (MAKE-VECTOR (CAR ,hash-name))))
(VSET (CDR ,hash-name)
HASHNO
(CONS ENTRY (VREF (CDR ,hash-name) HASHNO)))))
(defmacro STILL-VALID (name invalidator)
(or (|no-funp/|| invalidator)
(error '|Uluz, not a symbol - STILL-VALID| invalidator))
`(COND ((NULL ,invalidator) 'T)
((SI:INVALIDATED ,name ,invalidator) () )
('T)))
(defmacro symeval-for-counters (x)
`(CASEQ ,x ,.(mapcar #'(lambda (x) `(,x ,x)) defmax-counter-variables)))
(defmacro max*-counters (&rest w) `(MAX ,@w ,. defmax-counter-variables))
(defsimplemac set-counter-variables (val)
`(SETQ ,.(mapcan #'(lambda (x) `(,x ,val)) defmax-counter-variables)))
;;;; |forget-macromemos/||, FLUSH-MACROMEMOS
(defun |forget-macromemos/|| (x) (flush-macromemos x 'FLUSH-MACROMEMOS))
;; The MACROEXPANDED property of a symbol is either a fixnum, for a macro
;; which is sensitive only to its own redefinition; or else a list*
;; of three things -- a validation-symbol, definition-time-thereof, and
;; number of local cache flushings.
(defun FLUSH-MACROMEMOS (name validation-symbol &aux mxprop fxprop)
(cond ((null name)
(rplacd MACROMEMO () )
;; Then reset all counters to an incremented value
(setq |forgetfulness-max/||
(1+ (max*-counters |forgetfulness-max/||)))
(set-counter-variables |forgetfulness-max/||))
('T (setq mxprop (get name MACROEXPANDED))
(cond ((or mxprop (fboundp name))
;; Remove instances of this macro from the MACROMEMO cache
(do ((i (1- (car MACROMEMO)) (1- i)))
((< i 0))
(declare (fixnum i))
(vset (cdr MACROMEMO)
i
(delassq name (vref (cdr MACROMEMO) i))))
(if validation-symbol
;; Increment the counter of macro re-definitions
(setq FLUSH-MACROMEMOS (1+ FLUSH-MACROMEMOS)))))
(setq fxprop (and mxprop (atom mxprop)))
(cond ((null validation-symbol)
;; Local flushings, without redefinitions
(cond (fxprop (putprop name (1+ mxprop) MACROEXPANDED))
('T (if mxprop
;; No, no, don't use SETF here!!
(rplacd (cdr mxprop) (1+ (cddr mxprop)))))))
((putprop name
(cond
((eq validation-symbol MACROEXPANDED)
(if (null fxprop)
FLUSH-MACROMEMOS
(if (< mxprop |forgetfulness-max/||)
|forgetfulness-max/||
(1+ mxprop))))
((list* validation-symbol
(symeval-for-counters validation-symbol)
0)))
MACROEXPANDED)))))
name)
;;;; SI:INVALIDATED, and MACROFETCH
(defun SI:INVALIDATED (name invalidator)
(cond
((null invalidator) () )
((let ((mxprop (get name MACROEXPANDED))
(simple-invalidator (atom invalidator)))
(let ((invalidator-number (if simple-invalidator
invalidator
(car invalidator)))
(counter (typecaseq mxprop
(FIXNUM (if simple-invalidator mxprop))
(PAIR (if (not simple-invalidator)
(symeval-for-counters (car mxprop))))
(T (+internal-lossage () 'SI:INVALIDATED name)
() ))))
(cond ((or (null counter)
(< invalidator-number counter)
(< invalidator-number |forgetfulness-max/||))
'T)
((not simple-invalidator)
;; check for local flushings of a non-simple expansion
(< (cdr invalidator) (cddr mxprop)))
('T () )))))))
(defun MACROFETCH (form)
;; Look up form in memo-izing hash table. If there, entry is like
;; `(,oldform ,name ,expansion . ,invalidator)
(and (cdr MACROMEMO)
(setq form (hash-get form))
(let (( (() name expansion . invalidator) form))
(if (still-valid name invalidator)
expansion))))
;;;; MACROMEMO and MACROEXPANDED
;; An "invalidator" is either a fixnum, which compares with the fixnum
;; stored as the MACROEXPANDED property of the macro, or a pair of
;; expansion-time-value of a "counter", and a fixnum slot for local flushings.
(defun MACROMEMO (original-cell expansion name)
;; Basic "memoizer". Makes up a "validation" memo for this expansion
;; and either enters it into a hash table, or clobbers according to
;; the MACROEXPANDED style. May clobber back to original if the
;; state of the MACRO-EXPANSION-USE switch has changed.
(cond ((null MACRO-EXPANSION-USE) () )
((memq MACRO-EXPANSION-USE '(MACROEXPANDED MACROMEMO))
(let* ((mxpp (eq MACRO-EXPANSION-USE 'MACROEXPANDED))
(mxprop (get name MACROEXPANDED))
(invalidator
(cond ((atom mxprop)
(cond ((< mxprop |forgetfulness-max/||)
(flush-macromemos name MACROEXPANDED)
(setq mxprop (get name MACROEXPANDED))))
(and mxpp mxprop))
('T (list* (symeval-for-counters (car mxprop))
(cddr mxprop))))))
(cond ((and mxpp
#-(or LISPM MULTICS)
(not (static-areap original-cell)))
;; Notice copying original cell, in case it is displaced
(defmax-displace
original-cell
`(MACROEXPANDED ,name
,invalidator
,(cons (car original-cell)
(cdr original-cell))
,expansion)))
((null expansion) () )
((hash-put `(,original-cell ,name ,expansion . ,invalidator))))))
((eq MACRO-EXPANSION-USE 'DISPLACE)
#-(or LISPM MULTICS)
(cond ((not (static-areap original-cell))
(defmax-displace original-cell expansion))
((writeablep original-cell)
(defmax-displace original-cell (static-copy expansion))))
#+(or LISPM MULTICS)
(defmax-displace original-cell expansion))
;; Look for user's mispellings, and try to correct them
((eq MACRO-EXPANSION-USE MACROMEMO)
;; What a loser! Next time thru this fun, he'll win!
(setq MACRO-EXPANSION-USE 'MACROMEMO))
((or (eq MACRO-EXPANSION-USE MACROEXPANDED)
(eq MACRO-EXPANSION-USE 'MACROEXPAND)
(eq MACRO-EXPANSION-USE 'T)
(and #-NIL (boundp '*:TRUTH)
(eq MACRO-EXPANSION-USE *:TRUTH)))
;; Ditto. Remember, these are unique values.
(setq MACRO-EXPANSION-USE 'MACROEXPANDED))
((typecaseq MACRO-EXPANSION-USE
(SYMBOL (fboundp MACRO-EXPANSION-USE))
#N (SUBR *:TRUTH)
(PAIR (eq (car MACRO-EXPANSION-USE) 'LAMBDA)))
;; Perhaps a user "hook"?
(funcall MACRO-EXPANSION-USE original-cell expansion)))
expansion)
(defun (MACROEXPANDED macro) (form)
;; (MACROEXPANDED <name> <invalidator> <original-form> <expanded-form>)
;; <invalidator> is either
;; (1) a fixnum, meaning compare it with the version number of this
;; particular macro, stored as the MACROEXPANDED property.
;; (2) a pair of fixnum and symbol -- symbol is name of counter whose
;; current value is to be compared with the fixnum
;; (3) null, meaning no need to un-macroize ever
(let ((tail (cddr form)))
(cond ((and (cond ((eq MACRO-EXPANSION-USE 'MACROEXPANDED))
((or (eq MACRO-EXPANSION-USE MACROEXPANDED)
(eq MACRO-EXPANSION-USE 'MACROEXPAND))
(setq MACRO-EXPANSION-USE 'MACROEXPANDED)))
(still-valid (cadr form) (car tail)))
(caddr tail))
('T ;; Revert to original form otherwise, and try expanding again
(defmax-displace form (cadr tail))))))
(DEFPROP MACROEXPANDED |MACROEXPANDED-grindmacro/|| GRINDMACRO)
;;;; MACROEXPAND, MACROEXPAND-1*, MACROEXPAND-1*M, etc.
#-LISPM (progn 'compile
(defun MACROEXPAND (form &aux (ex? 'T))
(or (atom form)
(do ()
((or (not ex?) (atom form)) )
(multiple-value (form ex?) (macroexpand-1*m form))))
(values form ex?))
;;; MACROEXPAND-1 returns the one-step expansion of a macro.
(defun MACROEXPAND-1 (form)
(or (atom form)
(multiple-value (form) (macroexpand-1*m form)))
form)
) ;end of #-LISPM
;Following global variable is actually set up at beginning of this file
;(defvar FIND-MACRO-DEFINITION #'FIND-MACRO-DEFINITION
; "How to find a macro definition. Funcalled on a symbol,
; it should return something to FUNCALL to expand that macro
; once, or return () meaning the symbol isn't defined as a macro.")
(defun FIND-MACRO-DEFINITION (frob &aux fval)
;;; Find a macro definition wherever it lives
(declare (special macrolist))
(cond ((not (symbolp frob)) ())
((and (boundp 'MACROLIST) (cdr (assq frob macrolist))))
(#M (setq fval (get frob 'MACRO))
#-MacLISP
(and (fboundp frob)
(pairp (setq fval (fsymeval frob)))
(eq (car fval) 'MACRO)
(prog2 (setq fval (cdr fval)) 'T))
fval)
((+internal-try-autoloadp frob)
(find-macro-definition frob))))
;; Following is like MACROEXPAND-1, but arg must be non-atomic. Returns:
; (1) one step in the expansion and of
; (2) a flag #T or () depending on whether expansion actually occurred
(defun MACROEXPAND-1*M (x &aux (fun (car x)) fval (mcx x) ex?)
(cond
((not (atom fun))
(cond ((eq (car fun) 'MACRO)
(setq ex? t)
(setq mcx (funcall (cdr fun) x)))
((not (eq (car fun) 'LAMBDA))
(multiple-value (mcx ex?) (macroexpand-1*m fun))
(setq mcx (if ex?
(cons mcx (cdr x))
x)))))
((setq fval (if (eq FIND-MACRO-DEFINITION #'FIND-MACRO-DEFINITION)
(find-macro-definition fun)
(funcall find-macro-definition fun)))
(setq mcx (funcall fval x)
ex? 't)))
(values mcx ex?))
;Following is like MACROEXPAND-1, but arg is guaranteed non-atomic, and
;returns () if no expansion happens, or NCONS of the expansion otherwise.
(defun MACROEXPAND-1* (form &aux ex?)
(multiple-value (form ex?) (macroexpand-1*m form))
(if ex? (list form)))
#Q (defun MACROEXPAND-1* (x)
((lambda (ocarx ocdrx val)
(setq val (macroexpand-1 x))
(cond ((atom x) (ferror nil "~SAtomic arg to MACROEXPAND-1*" X))
((and (eq x val) (eq ocarx (car x)) (eq ocdrx (cdr x)))
() )
((list val))))
(car x) (cdr x) () ))
;;;; +INTERNAL-TRY-AUTOLOADP
(defun +INTERNAL-TRY-AUTOLOADP (fun &aux (file (get fun 'AUTOLOAD)))
; Try autoloading, if possible. return non-null iff succeed
(cond ((and file (not (fboundp fun)))
(do ()
((probef file))
(setq file (cerror 'T () ':WRONG-TYPE-ARG
";~1G~S, autoload file for ~2G~S, is missing"
() file fun)))
(funcall autoload (cons fun file))
(cond ((fboundp fun) 'T)
((setq fun (cerror 'T () ':UNDEFINED-FUNCTION
";~S was not functionally defined by autoloading"
fun))
(+internal-try-autoloadp fun))))))

404
src/nilcom/defvst.164 Executable file
View File

@@ -0,0 +1,404 @@
;;; DEFVST -*-Mode:Lisp;Package:SI-*-
;;; *************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer ********************
;;; *************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology *******
;;; ************ this is a read-only file! (all writes reserved) ************
;;; *************************************************************************
;;; Acronym for "DEFine a Vector-like STructure"
;;; For documentation and examples, see the file LIBDOC;DEFVST DOC on the
;;; various ITS systems, and LISP:DEFVST.DOC on TOPS10/20 systems.
;;; For MacLISP, to compile NADEFVST (version to use in NIL-aided MacLISP),
;;; just load the SHARPC module, and set TARGET-FEATURES to 'NILAID
(herald DEFVST /164)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
#-NIL
(subload SHARPCONDITIONALS)
)
;;Remember: a NILAID also will be a MacLISP
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "DEFVST")
(globalize "CONSTRUCTOR-NAMESTRING-PREFIX")
(globalize "SELECTOR-NAMESTRING-STYLE")
)
;; Load DEFVSX and DEFMAX now to get their "globalizations"
;; Load EXTEND before DEFVSX so that CLASS system will be available
#-NIL
(eval-when (eval compile load)
(subload EXTEND)
(subload VECTOR)
(subload DEFVSX) ;Will subload DEFMAX and DEFVSY
)
#-(local NIL)
(eval-when (eval compile)
(subload EXTEND) ;Bring these guys in before DEFVSX,
(subload EXTMAC) ; so that the CLASS system will be
(subload VECTOR) ; alive by then.
(subload DEFVSX) ;Loading DEFVSX will also do
; (subload DEFMAX)
; (subload DEFVSY)
(subload DEFSETF)
(subload UMLMAC)
)
(declare (special DEFMACRO-DISPLACE-CALL
CONSTRUCTOR-NAMESTRING-PREFIX
SELECTOR-NAMESTRING-STYLE
STRUCT-CLASS
STRUCT=INFO-CLASS
|defvst-typchk/||
|defvst-construction/||)
#+MacLISP (*lexpr TO-VECTOR))
#+MacLISP
(eval-when (eval compile load)
(cond ((status feature COMPLR)
(*expr |defvst-construction/|| |defvst-construction-1/||
|defvst-typchk/||)
(*lexpr |defvst-initialize/||)))
)
(MAPC '(LAMBDA (X Y) (AND (NOT (BOUNDP X)) (SET X Y)))
'(SELECTOR-NAMESTRING-STYLE CONSTRUCTOR-NAMESTRING-PREFIX )
'(|-| |CONS-A-| ))
#+(and MacLISP NIL)
(include #+(local ITS) ((NILCOM) DEFVSY >)
#-(local ITS) ((LISP) DEFVSY LSP))
#+(and MacLISP NIL)
(include #+(local ITS) ((NILCOM) DEFVSX >)
#-(local ITS) ((LISP) DEFVSX LSP))
#+(local MacLISP)
(eval-when (compile)
(defprop DEFVST T SKIP-WARNING)
;; FOO! to prevent circularities when compiling
(do ((i 0 (1+ i))
(l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l))
(z))
((null l))
(setq z (symbolconc 'STRUCT=INFO- (car l)))
(eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i))))
)
;;;; DEFVST macro
(defmacro (DEFVST defmacro-displace-call () ) (sname &rest selkeys &whole form)
(LET ((NKEYS 0)
(SELECTOR-NAMESTRING-STYLE SELECTOR-NAMESTRING-STYLE)
(CONSTRUCTOR-NAMESTRING-PREFIX CONSTRUCTOR-NAMESTRING-PREFIX)
(OUTPUT-SELECTOR-MACROS 'T)
CONSTRUCTOR-NAME RESTKEY RESTSIZEFORM RESTP SELINIS MAC-ARG-NM
SNAME-CLASS-VAR TMP OPTION-LIST )
(DECLARE (FIXNUM I NKEYS))
(COND ((NOT (ATOM SNAME))
(SETQ OPTION-LIST (CDR SNAME))
(SETQ SNAME (CAR SNAME))
(IF (ASSQ 'NO-SELECTOR-MACROS OPTION-LIST)
(SETQ OUTPUT-SELECTOR-MACROS () ))))
(AND (OR (NULL SNAME) (NOT (SYMBOLP SNAME)))
(ERROR "Bad name arg - DEFVST" FORM))
(SETQ SNAME-CLASS-VAR (SYMBOLCONC SNAME '-CLASS))
(SETQ NKEYS (LENGTH SELKEYS))
(COND ((SETQ TMP (MEMQ '&REST SELKEYS))
(SETQ NKEYS (- NKEYS (LENGTH TMP))
RESTKEY (CADR TMP)
RESTSIZEFORM (CADDR TMP))
(AND (OR (NOT (SYMBOLP RESTKEY)) (NULL RESTSIZEFORM))
(ERROR "Bad &REST item - DEFVST" SELKEYS))))
(COND ((GET SNAME 'STRUCT=INFO)
(TERPRI MSGFILES)
(PRINC "Warning! Redefining the STRUCTURE " MSGFILES)
(PRIN1 SNAME MSGFILES)))
(SETQ MAC-ARG-NM (SYMBOLCONC SNAME '|-MACRO-ARG|))
(SETQ CONSTRUCTOR-NAME
(COND ((SETQ TMP (ASSQ 'CONSTRUCTOR OPTION-LIST))
(CADR TMP))
('T (SYMBOLCONC CONSTRUCTOR-NAMESTRING-PREFIX SNAME))))
;RESTP and SELINIS start out null here
(DO ( (I 1 (1+ I))
(L SELKEYS (CDR L))
INIFORM TYP /=-/:-COUNT KEYNM SELNM )
( (OR (NULL L) RESTP) )
(COND ((ATOM (SETQ KEYNM (CAR L)))
(COND ((EQ KEYNM '&REST)
(SETQ KEYNM RESTKEY RESTP 'T)
(AND (NOT (EQ RESTKEY (CADR L)))
(+INTERNAL-LOSSAGE '&REST 'DEFVST SELKEYS)))
((NOT (SYMBOLP KEYNM))
(ERROR "Key name not a symbol - DEFVST" KEYNM)))
(SETQ INIFORM () ))
('T (AND (OR (NULL (SETQ KEYNM (CAR KEYNM)))
(NOT (SYMBOLP KEYNM)))
(ERROR "Bad key-list - DEFVST" SELKEYS))
(COND ((ATOM (SETQ TMP (CDAR L))) (SETQ INIFORM () ))
('T (SETQ /=-/:-COUNT 0 )
(AND (NULL (CDR TMP)) ;Allow LISPM-
(SETQ TMP `(= ,(car tmp)))) ; style inits
(COND ((SETQ TYP (MEMQ '|:| TMP))
(SETQ /=-/:-COUNT 1)
(SETQ TYP (COND ((ATOM (CADR TYP))
(LIST (CADR TYP)))
((CADR TYP))))))
(SETQ INIFORM
(COND ((SETQ INIFORM (MEMQ '= TMP))
(SETQ /=-/:-COUNT (1+ /=-/:-COUNT))
(CADR INIFORM))
(TYP (CDR (OR (ASSQ
(CAR TYP)
'((FIXNUM . 0)
(FLONUM . 0.0)
(BIGNUM . 500000000000000000000.)
(LIST . () )
(SYMBOL . 'FOO)
(ARRAY . () )
(HUNK . () )
))
#+NIL (ASSQ (CAR TYP)
'((SMALL-FLONUM 0.0)
(PAIR . '(() ))
(VECTOR . #.(if (fboundp 'make-vector)
(make-vector 0)
() ))
(STRING . "" )))
)))))
(AND (NOT (= /=-/:-COUNT 0))
(SETQ INIFORM (CONS INIFORM TYP)))
(COND ((NOT (= (* 2 /=-/:-COUNT) (LENGTH TMP)))
(PRINT (CAR L) MSGFILES)
(PRINC "Option list has options not yet coded ")))
))
))
(COND
((NOT OUTPUT-SELECTOR-MACROS) (PUSH `(,keynm) SELINIS))
('T (SETQ SELNM (IF (NULL SELECTOR-NAMESTRING-STYLE)
KEYNM
(SYMBOLCONC SNAME
SELECTOR-NAMESTRING-STYLE
KEYNM)))
(COND ((NOT RESTP)
;; INIFORM = (<initialization-form> <restrictions>...)
(PUSH `(,keynm ,selnm ,.iniform) SELINIS))
('T (SETQ RESTP `(,keynm ,selnm ,restsizeform))
(OR (= I (1+ NKEYS))
(+INTERNAL-LOSSAGE '&REST 'DEFVST i)))))))
`(EVAL-WHEN (EVAL COMPILE LOAD)
#-NIL #%(DEF-OR-AUTOLOADABLE |defvst-initialize/|| DEFVSY)
(AND #-NIL (STATUS FEATURE COMPLR)
(SPECIAL ,sname-class-var))
;; The next line is a crock to replace the line commented out
;; below --RWK
(DEFPROP ,sname ,sname-class-var CLASS-VAR)
(|defvst-initialize/||
',sname
',constructor-name
,nkeys
',(to-vector (cons restp (nreverse selinis)))
,SI:STRUCT=INFO-VERSION ;a version number
,(and (filep infile) `',(truename infile))
;; The next line is commented out until dumped out versions of
;; |defvst-initialize/|| without an &REST IGNORE or this argument
;; are re-dumped.
;; -- RWK, Sunday the twenty-first of June, 1981; 3:12:18 am
;; ,sname-class-var
)
,.(if restp
`((DEFPROP ,(cadr restp)
(,sname ,(1+ nkeys) &REST)
SELECTOR)))
',sname)))
;;;; Structure Printer
;; Someday, hack printing of &REST stuff
(DEFVAR SI:PRINLEVEL-EXCESS '|#|)
(DEFVAR SI:PRINLENGTH-EXCESS '|...|)
(defmethod* (:PRINT-SELF STRUCT-CLASS) (ob stream depth slashifyp)
(declare (fixnum depth))
(setq depth (1+ depth))
(if (and prinlevel (not (< depth prinlevel)))
(princ SI:PRINLEVEL-EXCESS stream)
(let* ((name (si:class-name (class-of ob)))
(info (get name 'STRUCT=INFO)))
(if (null info)
(si:print-extend-maknum ob stream)
(progn
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(princ '|#{| stream)
(do ((z (si:listify-struct-for-print ob name info) (cdr z))
(n 0 (1+ n))
(first 'T ()))
((null z))
(declare (fixnum n))
(or first (tyo #\SPACE stream))
(print-object (car z) depth slashifyp stream)
(cond ((and prinlength (not (< n PRINLENGTH)))
(tyo #\SPACE stream)
(princ SI:PRINLENGTH-EXCESS stream)
(return () ))))
(tyo #/} stream))))))
(defmethod* (SPRINT STRUCT-CLASS) (ob n m)
(declare (special L N M))
(let* ((name (si:class-name (class-of ob)))
(info (get name 'STRUCT=INFO)))
(if (null info)
(si:print-extend-maknum ob outfiles)
(let ((z (si:listify-struct-for-print ob name info)))
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(if (> (- (grchrct) 3.) (gflatsize z))
(prin1 ob)
(progn
(princ '|#{|)
(prin1 (car z))
(cond ((cdr z)
(tyo #\SPACE)
(setq N (grchrct) M (1+ M))
(do ((l (cdr z)))
((null l))
(grindform 'LINE)
(grindform 'CODE)
(cond (l (indent-to N))))))
(tyo #/})))))))
#+(or (not NIL) MacLISP)
(eval-when (eval compile)
(defmacro (VECTOR-LENGTH defmacro-for-compiling () defmacro-displace-call () )
(&rest w)
`(SI:EXTEND-LENGTH ,.w))
(defmacro (VREF defmacro-for-compiling () defmacro-displace-call () )
(&rest w)
`(SI:XREF ,.w))
)
;; Sure, this could do less consing, if it really wanted to. But who
;; wants to trouble to write such hairy code?
(DEFUN SI:LISTIFY-STRUCT-FOR-PRINT (OB NAME INFO)
(LET* ((SUPPRESS (GET NAME 'SUPPRESSED-COMPONENT-NAMES))
(INIS (STRUCT=INFO-INIS INFO)))
(DO ((I 1 (1+ I))
(N (VECTOR-LENGTH INIS))
(THE-LIST (LIST NAME)))
((NOT (< I N)) (NREVERSE THE-LIST))
;The (1+ i)th component of INIS corresponds to the ith
;component of OB. The 0th component of INIS corresponds
;to the &REST stuff which this code doesn't address.
(LET* (((NAME SELECTOR INIT) (VREF INIS I))
(VAL (SI:XREF OB
(OR (AND SELECTOR
(CADR (GET SELECTOR 'SELECTOR)))
(1- I)))))
(COND ((MEMQ NAME SUPPRESS))
;;Incredible kludge to avoid printing defaulted vals
((OR (AND (NULL INIT) (NULL VAL))
(AND (|constant-p/|| INIT)
(EQUAL VAL (EVAL INIT)))
(AND (PAIRP INIT)
(EQ (CAR INIT) 'QUOTE)
(EQUAL VAL (CADR INIT)))))
(T (PUSH NAME THE-LIST)
(PUSH VAL THE-LIST)))))))
(defmethod* (EQUAL struct-class) (ob other)
(or (eq ob other) ;generally, this will have already been done
(let ((ty1 (struct-typep ob))
(ty2 (struct-typep other)))
(cond ((or (null ty1) (null ty2) (not (eq ty1 ty2))) () )
((si:component-equal ob other))))))
(defmethod* (SUBST struct-class) (ob a b)
(si:subst-into-extend ob a b))
(defmethod* (SXHASH struct-class) (ob)
(si:hash-Q-extend ob #.(sxhash 'STRUCT)))
(defmethod* (DESCRIBE struct-class) (ob stream level)
(declare (special SI:DESCRIBE-MAX-LEVEL))
(if (not (> level SI:DESCRIBE-MAX-LEVEL))
(let* ((name (struct-typep ob))
(info (get name 'STRUCT=INFO)))
(if (null info)
()
(let* ((inis (STRUCT=INFO-inis info))
(ninis (vector-length inis))
(suppress (get name 'SUPPRESSED-COMPONENT-NAMES)))
(si:verify-defvst-version name (STRUCT=INFO-vers info))
(format stream
"~%~vTThe named structure has STRUCT-TYPEP ~S"
level name)
(if suppress
(format stream
"~%~vtThese component names are suppressed: ~S"
level suppress))
(format stream
"~%~vtThe ~D. component names and contents are:"
level (1- ninis))
(do ((i 1 (1+ i)) (default () ()))
((not (< i ninis)))
(let* (((name selector init) (vref inis i))
(sel (get (cadr (vref inis i)) 'SELECTOR))
(val (vref ob (if sel (cadr sel) (1- i)))))
(if (or (and (null init) (null val))
(and (|constant-p/|| init)
(equal val (eval init)))
(and (pairp init)
(eq (car init) 'QUOTE)
(equal val (cadr init))))
(setq default 'T))
(format stream
"~%~vt ~S: ~S ~:[~; [default]~]"
level (car (vref inis i)) val default)))
(if (vref inis 0)
(format stream
"~%~vt&REST part hasn't been Described."
level)))))))
#+(and MacLISP (not NIL))
(or (fboundp 'STRUCT-LET)
(equal (get 'STRUCT-LET 'AUTOLOAD) #%(autoload-filename UMLMAC))
(prog2 (defun STRUCT-LET macro (x)
((lambda (n FASLOAD)
(cond ((null n))
((alphalessp n "25")
(remprop 'UMLMAC 'VERSION))
((+internal-lossage 'UMLMAC 'STRUCT-LET n)))
(load #%(autoload-filename UMLMAC))
(macroexpand x))
(get 'UMLMAC 'VERSION)
() ))
(defun STRUCT-SETF macro (x)
((lambda (n FASLOAD)
(cond ((null n))
((alphalessp n "25")
(remprop 'UMLMAC 'VERSION))
((+internal-lossage 'UMLMAC 'STRUCT-SETF n)))
(load #%(autoload-filename UMLMAC))
(macroexpand x))
(get 'UMLMAC 'VERSION)
() ))))

358
src/nilcom/defvsx.106 Executable file
View File

@@ -0,0 +1,358 @@
;;; DEFVSX -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer Aux, Part 1 ********
;;; *************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology *******
;;; *************************************************************************
;;; Auxillary file for DEFVST -- can stand alone in runtime environment.
;;; Builds up the STRUCT=INFO descriptor, and has the constructor and
;;; selector helper functions.
;;; In MacLISP, this file is INCLUDE'd in DEFVST for NADEFVST
(herald DEFVSX /106)
#-NIL
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload SHARPCONDITIONALS)
)
#+(local MacLISP)
(declare (mapc '(lambda (x) (putprop x T 'SKIP-WARNING))
'(SETVST |defvst-selection-1/|| |defvst-xref/||
|defvst-construction-1/|| |defvst-construction/||)))
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "SETVST")
(globalize "defvst-construction/|") ;is globalized by DEFMAX too
(globalize "defvst-construction-1/|")
(globalize "defvst-selection-1/|")
(globalize "defvst-xref/|")
)
;; One reason for loading DEFMAX now is to get all its "globalizations"
#+MacLISP
(eval-when (eval load compile)
(subload DEFMAX)
(subload DEFVSY)
)
#+(local MacLISP)
(eval-when (eval compile)
(subload DEFMAX)
(subload DEFVSY)
(subload EXTEND) ;also subloads EXTSTR and EXTBAS
(subload EXTMAC)
(subload EXTHUK)
;; (subload VECTOR)
(defmacro VECTOR-LENGTH (v) `(SI:EXTEND-LENGTH ,v))
(defmacro VREF (v n) `(SI:XREF ,v ,n))
(subload DEFSETF)
)
;;;; Declarations and temporary macros
#+(and MacLISP (not NIL))
(progn 'COMPILE
(defvar SI:STRUCTS-OUTPUT-TO-FASL ()
"Structures which have been output to the FASL file already")
(defvar SI:EXTSTR-AUTOLOAD-OUTPUT-TO-FASL ()
"Says we've already put an autoload for DEFVSY to the FASL file")
)
;; Either EXTEND will have done a DEFCLASS* for STRUCT=INFO-CLASS, or else
;; DEFVSY will have set up the skeleton. Hence #. can use STRUCT=INFO-CLASS
(eval-when (compile)
(special STRUCT-CLASS STRUCT=INFO-CLASS |defvst-construction/|| PRATTSTACK)
(setq defmacro-for-compiling () )
#+MacLISP
(progn (*expr MACROEXPAND-1*) (*lexpr CERROR SI:DEFVST-BARE-INIT))
)
;; FOO! to prevent circularities when compiling
#+(local MacLISP)
(eval-when (compile)
(do ((i 0 (1+ i))
(l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l))
(z))
((null l))
(setq z (symbolconc 'STRUCT=INFO- (car l)))
(eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i))))
)
(eval-when (compile)
(setq defmacro-for-compiling 'T )
)
;;;; Run-time Support Code
;;;; SETVST
(DEFMACRO (SETVST defmacro-displace-call 'T) (ARGL VAL)
(PROG (TEM X SNAME)
A (SETQ X ARGL)
B (AND (OR (ATOM X) ;lose on atom, or
(NULL (SETQ SNAME (CAR X))) ; other bad format
(NOT (SYMBOLP SNAME)))
(GO LUZEZ))
;; SELECTOR prop should be either (NAME i) or (NAME i &REST)
(AND (SETQ TEM (GET SNAME 'SELECTOR)) ;lose if wrong
(OR (COND ((NULL (CDDR TEM)) (CDDR X)) ; kind of selector
('T (NULL (CDDR X))))
(CDDDR X))
(GO LUZEZ))
(COND
((MEMQ (CAR X) '(|defvst-xref/|| SI:XREF *:XREF))
(return #+(and MacLISP (not NIL))
(sublis `((X . ,(cadr x))
(I . ,(caddr x))
(Z . ,val))
'#%(SI:XSET X I Z))
#-(and MacLISP (not NIL))
`(SI:XSET ,(cadr x) ,(caddr x) ,val)))
((SETQ TEM (MACROEXPAND-1* X))
(SETQ X (CAR TEM))
(GO B)))
LUZEZ (SETQ ARGL (CERROR 'T () ':WRONG-TYPE-ARGUMENT
'|~1G~S is not recognizable as a structure component selection -- ~S ~:[~% Last expansion resulted in ~S ~]|
'T ARGL 'SETVST (NOT (EQ ARGL X)) X))
(GO A)))
;;;; |defvst-selection-1/||, |defvst-xref/||, |defvst-construction/||
(defprop |defvst-general-selector/|| |defvst-selection-1/|| MACRO)
(defun |defvst-selection-1/|| (x)
(or (macrofetch x)
(prog (selname struct more? sname index restp sinfo xx)
A (cond ((eq (car x) '|defvst-general-selector/||)
;; In this case, the arg list is (name slot-number frob)
(desetq (() sname index struct) x)
(if (or (not (symbolp sname))
(null (setq sinfo (get sname 'STRUCT=INFO)))
(not (fixnump index)))
(+internal-lossage '|defvst-general-selector/||
'|defvst-selection-1/||
(list sname index)))
(setq selname (car (vref (STRUCT=INFO-inis sinfo)
(1+ index)))))
('T (desetq (selname struct . more?) x
(sname index . restp) (get selname 'SELECTOR))
(setq sinfo (get sname 'STRUCT=INFO))))
(cond ((or (if more? (or (cdr more?) (not restp)))
(if restp (or (not more?)
(not (eq (car restp) '&REST))))
(null sinfo) ;no struct=info prop?
(not (eq (struct-typep sinfo) 'STRUCT=INFO)))
(setq x (cerror 'T () ':WRONG-TYPE-ARGUMENT
'|~1G~S is not recognizable as a structure component selection -- ~S ~:[~% Last expansion resulted in ~S ~]|
'T x '|defvst-selection-1/|| () () ))
(go A)))
;; (si:check-defvst-version sname) ;Ensure up-to-date STRUCT=INFO
(si:verify-defvst-version sname (STRUCT=INFO-vers sinfo))
(if restp (setq index `(+ ,index ,(car more?))))
(setq xx (if (memq COMPILER-STATE '(() TOPLEVEL))
`(|defvst-xref/|| ,struct ,index ',sname ',selname)
`(SI:XREF ,struct ,index)))
(return (macromemo x xx selname)))
))
(defmacro |defvst-reference-by-name/|| (name key-index selname object
&whole form)
(cond (*RSET
(check-type name #'SYMBOLP '|defvst-reference-by-name/||)
(check-type key-index #'FIXNUMP '|defvst-reference-by-name/||)
(let ((sinfo (get name 'STRUCT=INFO)))
(if (or (not (eq (struct-typep sinfo) 'STRUCT=INFO))
(< key-index 0)
(not (< key-index (STRUCT=INFO-size sinfo))))
(ferror () "Inconsistent structure expansion request -- ~S" form)))))
(if (memq COMPILER-STATE '(() TOPLEVEL))
`(|defvst-xref/|| ,object ,key-index ',name ',selname)
`(SI:XREF ,object ,key-index)))
(defun |defvst-xref/|| (struct index sname selname)
(cond ((or (null *RSET) (eq (struct-typep struct) sname))
(si:xref struct index))
((cerror 'T () ':INCONSISTENT-ARGUMENTS
"The struct selector ~1G~S is being applied to ~S which isn't a ~S"
(list selname struct) selname struct sname))))
(defsetf |defvst-xref/|| ((() struct index sname selname) val) ()
`(SI:XSET ,struct ,index ,val))
(defun |defvst-construction-1/|| (x)
(or (macrofetch x)
(let (ol cnsn sname sinfo)
(do ()
((and (setq ol (cdr x) cnsn (car x))
(setq sname (get cnsn 'CONSTRUCTOR))
(setq sinfo (get sname 'STRUCT=INFO))))
(setq x (cerror 'T () ':WRONG-TYPE-ARGUMENT
"~S is not recognizable as a structure construction -- ~S"
'T x '|defvst-construction-1/||)))
(macromemo
x
(|defvst-construction/|| sname ol)
cnsn))))
;;;; |defvst-construction/||
(defun |defvst-construction/|| (sname argl)
(LET ((OVERRIDES ARGL)
(SINFO (GET SNAME 'STRUCT=INFO))
(NKEYS 0)
(TOTSIZE 0)
RESTRICTIONSP INIS ACCESSOR-MAC INSTANCEIZER RESTP
BL OL NOL TMP PROGN-LIST)
(DECLARE (FIXNUM NKEYS TOTSIZE))
(IF (NOT (STRUCT-TYPEP SINFO))
(+INTERNAL-LOSSAGE 'STRUCT-TYPEP
'|defvst-construction/||
(CONS SNAME ARGL)))
;; (SI:CHECK-DEFVST-VERSION SNAME) ;Ensure up-to-date STRUCT=INFO
(si:verify-defvst-version sname (STRUCT=INFO-vers sinfo))
(SETQ INIS (STRUCT=INFO-INIS SINFO)
NKEYS (STRUCT=INFO-SIZE SINFO))
(SETQ RESTP (VREF INIS 0))
(SETQ TOTSIZE NKEYS)
(AND OVERRIDES (PUSH () OVERRIDES))
(IF RESTP
(SETQ TOTSIZE
(+ TOTSIZE
(COND ((AND OVERRIDES (SETQ TMP (GET (CAR RESTP) OVERRIDES)))
(COND ((EQ (TYPEP TMP) 'FIXNUM))
((> TMP -1))
((+INTERNAL-LOSSAGE '&REST
'|defvst-construction/||
(CONS SNAME ARGL))))
TMP)
((CADDR RESTP))))))
(DO ( (I NKEYS (1- I)) (OVERRIDE? () ()) (KEYNAME) (TYPL) (FORM) )
( (< I 1) )
(DESETQ (KEYNAME ACCESSOR-MAC FORM . TYPL) (VREF INIS I))
(SETQ ACCESSOR-MAC
(COND (ACCESSOR-MAC
`(,accessor-mac CURRENT-CONSTRUCTION))
('T (if typl (+internal-lossage 'SELECTOR
'|defvst-construction/||
sname))
`(SI:XREF CURRENT-CONSTRUCTION ,(1- i)))))
(IF (SETQ TMP (GETL OVERRIDES (LIST KEYNAME)))
(SETQ FORM (CADR TMP) OVERRIDE? 'T))
(AND FORM
(SETQ FORM `(SETVST ,accessor-mac
,(cond ((null typl) form)
('t (setq restrictionsp '(() ))
`(|defvst-typchk/||
,form
',typl
',accessor-mac)))))
(IF OVERRIDE?
(PUSH (CONS KEYNAME FORM) OL)
(PUSH FORM BL))))
;BL is the Basic List of component setups, obtained from the non-null
; default initializations (initialization to null can be elided)
;OL is the list of overriding initializatons provided by this
; particular call to the constructor.
;There has to be an ordering such that basic one are done first,
; and then the overrides in the order supplied by the caller.
;Sort by order seen the the caller.
(DO ((L (CDR OVERRIDES) (CDDR L)))
((NULL L))
(SETQ TMP (CAR L))
(DO ()
((DO ((I (1- (VECTOR-LENGTH INIS)) (1- I)))
((< I 0))
(DECLARE (FIXNUM I))
;; (VECTOR-POSASSQ TMP INIS)
(IF (EQ TMP (CAR (VREF INIS I))) (RETURN 'T))))
(SETQ TMP (CERROR 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S Bad key word while cons'ing a ~S structure."
() TMP SNAME)))
(IF (SETQ TMP (ASSQ TMP OL)) (PUSH (CDR TMP) NOL)))
;; Ensure that the class will be defined. Remember that things are
;; taken from PRATTSTACK in inverse order, so the DEFPROP really does
;; happen at the right time.
#+MacLISP
(cond ((and (status feature COMPLR)
(memq compiler-state '(COMPILE MAKLAP))
(not (memq sname SI:STRUCTS-OUTPUT-TO-FASL)))
;; Output enough info to initialize everything.
(let* ((sclass (get sname 'CLASS))
(bare-init
`(SI:DEFVST-BARE-INIT
',sname
',(or (si:class-var sclass)
(symbolconc sname '|-CLASS|))
',(STRUCT=INFO-cnsn sinfo)
,nkeys
;; Open-coding of TO-LIST to avoid VECTOR file
',(do ((idx (1- (vector-length inis)) (1- idx))
(z () (cons (vref inis idx) z)))
((< idx 0) z)
(declare (fixnum idx)))
,SI:STRUCT=INFO-VERSION
',(get (si:class-plist (get sname 'CLASS))
':SOURCE-FILE))))
(push bare-init PRATTSTACK)
(if (not (eq compiler-state 'COMPILE))
(push bare-init progn-list)))
(cond ((null SI:EXTSTR-AUTOLOAD-OUTPUT-TO-FASL)
(push '#%(subload EXTSTR) PRATTSTACK)
(if (not (eq compiler-state 'COMPILE))
(push '#%(subload EXTSTR) progn-list))))
(setq SI:EXTSTR-AUTOLOAD-OUTPUT-TO-FASL T )
;; Don't repeat this mickey-mouse!
(push sname SI:STRUCTS-OUTPUT-TO-FASL)))
(SETQ INSTANCEIZER
;; Do things this way to get the COMPILE-time expansion
;; of SI:MAKE-EXTEND which should be good at runtime too.
#+(and MacLISP (not NIL))
`#%(SI:MAKE-EXTEND ,totsize ,(symbolconc sname '-CLASS))
#-(and MacLISP (not NIL))
`(SI:MAKE-EXTEND ,totsize ,(symbolconc sname '-CLASS))
)
(IF (AND (NULL BL) (NULL NOL))
INSTANCEIZER
`(PROGN ,@progn-list
(LET ((CURRENT-CONSTRUCTION ,instanceizer))
,.(nreconc bl (nreconc nol '(CURRENT-CONSTRUCTION))))))))
;;(defun SI:CHECK-DEFVST-VERSION (sname)
;; (let ((sinfo (get sname 'STRUCT=INFO)))
;; (cond (sinfo ;If not done yet, it's OK
;; ;; fixups and conversions
;; #M (if (= (STRUCT=INFO-vers sinfo) 1) ;Version 1 and 2 are
;; (setf (STRUCT=INFO-vers sinfo) 2)) ; almost identical
;; ;; Add new fixups and conversions here.
;; (si:verify-defvst-version sname (STRUCT=INFO-vers sinfo))))))
#+MacLISP
(progn 'COMPILE
(if (status feature COMPLR)
;;Technically, we need to do this. Also, on COMPLR reinitialization.
(push '(lambda () (setq SI:STRUCTS-OUTPUT-TO-FASL ()
SI:EXTSTR-AUTOLOAD-OUTPUT-TO-FASL () ))
SPLITFILE-HOOK))
#-NIL (progn 'compile
(def-or-autoloadable GENTEMP MACAID)
(def-or-autoloadable SI:XREF EXTBAS)
(def-or-autoloadable SI:XSET EXTBAS))
)

264
src/nilcom/defvsy.84 Executable file
View File

@@ -0,0 +1,264 @@
;;; DEFVSY -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; **************************************************************************
;;; ***** NIL ****** NIL/MACLISP/LISPM Structure Definer Aux, Part 2 *********
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; **************************************************************************
;;; Auxillary file for DEFVST -- can stand alone in runtime environment.
;;; In MacLISP, this file is INCLUDE'd in DEFVST for NADEFVST
(herald DEFVSY /84)
;; Some of the following will have already been done by DEFVST when
;; targeting for some kind of NIL (cross-compilation, or NILAID).
#-NIL
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload SHARPCONDITIONALS)
(subload EXTEND)
(subload EXTMAC)
(subload VECTOR)
)
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "defvst-initialize/|")
(globalize "STRUCT-TYPEP")
(globalize "defvst-typchk/|")
)
#+(and MacLISP (not NIL))
(progn 'compile
(subload EXTSTR)
(def-or-autoloadable |defvst-construction-1/|| DEFVSX)
)
#+(local MACLISP)
(declare (mapc '(lambda (x) (putprop x T 'SKIP-WARNING))
'(STRUCT-TYPEP)))
(eval-when (eval compile)
(cond ((status feature COMPLR)
(special STRUCT-CLASS STRUCT=INFO-CLASS |defvst-construction/||)
#+MacLISP
(*lexpr SI:DEFVST-BARE-INIT SI:DEFCLASS*-1 |defvst-initialize/||)))
#+(local MacLISP)
(do ((i 0 (1+ i))
(l '(VERS NAME CNSN SIZE INIS CLSS) (cdr l))
(z))
((null l))
(setq z (symbolconc 'STRUCT=INFO- (car l)))
(eval `(DEFMACRO ,z (X) `(SI:XREF ,X ,,i))))
(defmacro DEFVST-MACROIFY* (name fun)
#+MacLISP `(PUTPROP ,name ',fun 'MACRO)
#-MacLISP `(FSET ,name (CONS 'MACRO #',fun))
)
)
;(defvar SI:STRUCT=INFO-VERSION 2
; "Version # of STRUCT=INFO guys to allow automatic compatibility")
(eval-when (eval compile load)
(and (status feature COMPLR) (special SI:STRUCT=INFO-VERSION))
(setq SI:STRUCT=INFO-VERSION 2)
)
;;;; STRUCT-TYPEP, |defvst-typchk/||
(defun STRUCT-TYPEP (x)
(and
;;Note that in the #+FM case, the object time environment
;; is not a priori required to have the CLASS system.
#+(and (local PDP10) (not NIL))
(hunkp x)
#+NIL
(si:extendp x)
(setq x (si:extend-class-of x))
#+(and (local PDP10) (not NIL))
(and (hunkp x) (eq (si:extend-marker-of x) '#.si:class-marker))
(get (setq x (si:class-typep x)) 'STRUCT=INFO)
x))
(declare (own-symbol |defvst-initialize/|| |defvst-typchk/||))
(defun |defvst-typchk/|| (val typl accessor-mac)
;;Accessor-macro name has a SELECTOR property of "(<sname> <index>)"
;; where <sname> is the structure name, and <index> is the vector
;; index corresponding to the key-name
;;For now, the first slot of a structure-vector is taken up by the
;; &STRUCT marker, so the access of the initializations list(vector)
;; must be made to correspond.
(do ()
((memq (typep val) typl) val)
(let* ((selprop (get accessor-mac 'SELECTOR))
(sname (car selprop))
(key (car (si:xref (struct=info-inis (get sname 'STRUCT=INFO))
(cond ((eq (caddr selprop) '&REST) 0)
((1+ (cadr selprop))))))))
(setq val (cerror 'T () ':WRONG-TYPE-ARGUMENT
"~%Restriction Violation while creating a structure. The ~2G~S component of ~S is being set to ~1G~S, which is supposed to be of type ~0G~S"
(if (cdr typl) typl (car typl)) val key sname)))))
(defun SI:VERIFY-DEFVST-VERSION (sname version)
(if (= version 1) ;Version 1 and 2 are almost
(setq version 2)) ;identical
(if (not (= version SI:STRUCT=INFO-VERSION))
(ferror ':WRONG-TYPE-ARGUMENT
"~A is an unknown version of structure definition, current version = ~A"
sname SI:STRUCT=INFO-VERSION)))
;;;; |defvst-initialize/||
;;;Move &OPTIONAL to after VERSION once old files are flushed (after
;;; defvst-version 1 is gone). July 4, 1981 -- JonL --
(defun |defvst-initialize/|| (sname cnsn nkeys inis
&optional (version 1) source-file sname-class-var
&rest ignore
&aux sname-class sinfo inivec? (inislength 0) )
(declare (fixnum inislength))
(si:verify-defvst-version sname version)
(setq inislength (cond ((or (null inis) (pairp inis)) (length inis))
('T (setq inivec? 'T)
(vector-length inis))))
;; Get STRUCT=INFO, the class, and the class variable. The class variable
;; is not needed if we already have a STRUCT=INFO frob. There can be a
;; class object before a STRUCT=INFO object, by loading a file with an
;; instance of an object before its DEFVST, thanks to USERATOMS-HOOK hackery
(cond ((setq sinfo (get sname 'STRUCT=INFO))
(setq sname-class (STRUCT=INFO-clss sinfo))
(if (null sname-class)
(+internal-lossage 'STRUCT=INFO-clss '|defvst-initialize/||
sname)))
((setq sname-class (get sname 'CLASS))
(setq sname-class-var (si:class-var sname-class)))
((not (null sname-class-var)))
;;Next line a temporary hack until version 1 goes away
;; --RWK Sunday the twenty-first of June, 1981; 4:51:26 am
;;See also the dated comment in the EXTSTR file near SI:DEFVST-BARE-INIT
((setq sname-class-var (get sname 'CLASS-VAR)))
(T (setq sname-class-var (symbolconc sname "-CLASS"))))
(cond
((null sname-class) () )
((and sinfo
;;If re-defining to be the same thing, then nothing to do
;; Maybe should ignore the initializations as not incompatible if
;; changed?
(= nkeys (STRUCT=INFO-size sinfo))
(eq cnsn (STRUCT=INFO-cnsn sinfo))
(let* ((prev-inis (STRUCT=INFO-inis sinfo))
(ln (vector-length prev-inis)))
(and (= inislength ln)
;;Determine whether the two 'inis' are component-wise equal.
(do ((i 0 (1+ i))
(l-v inis))
((>= i ln) 'T)
(declare (fixnum i))
(if (not (equal (vref prev-inis i)
(if inivec? (vref l-v i) (pop l-v))))
(return () ))))))
() )
;;First defining of a class can happen via USERATOMS-HOOK, so
;; we add STRUCT=INFO
((null sinfo) () )
('T
#+(and MacLISP (not NIL))
(progn (terpri msgfiles)
(princ ";Warning! Incompatibly redefining the structure " msgfiles)
(prin1 sname msgfiles)
(terpri msgfiles)
(princ "; Methods will not be preserved in the newly-created class." msgfiles)
)
#-(and MacLISP (not NIL))
(format ERROR-OUTPUT "~%;Warning! Incompatibly redefining the structure ~S~%; Methods will not be preserved in the newly-created class." sname)
;;Cause new class to be used
(setq |defvst-construction/|| (1+ |defvst-construction/||)
sname-class () )))
(cond ((or (null sname-class) (null sinfo))
;;For MacLISP, following fun is defined in EXTSTR, and does the
;; puptrop of the STRUCT=INFO property, and a "si:defclass*-2"
;; if needed.
(si:DEFVST-bare-init sname
sname-class-var
cnsn
nkeys
inis
version
source-file)
;; Be sure to get everything up-to-date.
(setq sinfo (get sname 'STRUCT=INFO)
sname-class (STRUCT=INFO-clss sinfo)
inis (STRUCT=INFO-inis sinfo))))
(flush-macromemos cnsn MACROEXPANDED)
;; Now we vivify the macros.
(defvst-macroify* cnsn |defvst-construction-1/||)
(putprop cnsn sname 'CONSTRUCTOR)
(do ((i 0 (1+ i))
(n-inis (1- (vector-length inis)))
(selnm))
((= i n-inis))
(declare (fixnum i n-inis))
(cond ((setq selnm (cadr (vref inis (1+ i)))) ;Each inis slot is a list,
(flush-macromemos selnm MACROEXPANDED) ;of KEYNAME, SELECTOR-NAME
(putprop selnm `(,sname ,i) 'SELECTOR)
(defvst-macroify* selnm |defvst-selection-1/||)))))
(eval-when (eval compile)
(defmacro initial-STRUCT=INFO-inis-list ()
;; Key-names with info for default initial forms.
''(() ;&REST info
(VERS STRUCT=INFO-VERS SI:STRUCT=INFO-VERSION ) ;1st key
(NAME STRUCT=INFO-NAME () ) ;2st key
(CNSN STRUCT=INFO-CNSN () ) ;3nd
(SIZE STRUCT=INFO-SIZE 0 ) ;4rd
(INIS STRUCT=INFO-INIS () ) ;5th
(CLSS STRUCT=INFO-CLSS STRUCT=INFO-CLASS)) ) ;6th
(defmacro make-initial-STRUCT=INFO-inis ()
;;Ha! The following code for MacLISP makes up an "initializations"
;; vector for a STRUCT=INFO without having VECTOR or EXTBAS loaded
#+(and MacLISP (not NIL))
`(SI:EXTEND ,vector-class ,.(mapcar '(lambda (x) `',x)
(initial-STRUCT=INFO-inis-list)))
#-(and MacLISP (not NIL))
(to-vector (initial-STRUCT=INFO-inis-list)))
)
(|defvst-initialize/||
'STRUCT=INFO
'CONS-A-STRUCT=INFO
6
(make-initial-STRUCT=INFO-inis)
2
(and (filep infile) (truename infile))
'STRUCT=INFO-CLASS)
#+(and MacLISP (not NIL))
(progn 'compile
(defun gen-autoloadables macro (x)
`(OR (BOUNDP 'SI:XREF)
,.(mapcan #'(lambda (y)
(mapcar #'(lambda (x)
`(DEF-OR-AUTOLOADABLE ,x ,(car y)))
(cadr y)))
'((EXTBAS (SI:XREF SI:XSET SI:EXTEND SI:MAKE-EXTEND
SI:EXTEND-LENGTH EXTEND-LENGTH ))
(SENDI (EXTENDP SI:EXTENDP))))))
(gen-autoloadables)
)

210
src/nilcom/errck.30 Executable file
View File

@@ -0,0 +1,210 @@
;;; ERRCK -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; **************************************************************************
;;; *** NIL ******** ERRor ChecKing and correcting ***************************
;;; **************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **************
;;; **************************************************************************
(herald ERRCK /30)
#-NIL (include ((lisp) subload lsp))
#-NIL
(eval-when (eval compile)
(subload SHARPCONDITIONALS)
)
#+(or LISPM (and NIL (not MacLISP)))
(globalize "ERROR-RESTART"
"CHECK-ARG"
"CHECK-ARG-CONTROL-STRING"
"CHECK-TYPE"
"CHECK-SUBSEQUENCE"
)
#-For-NIL
(eval-when (eval compile)
(subload UMLMAC)
)
#M (declare (own-symbol ERROR-RESTART CHECK-ARG
CHECK-TYPE CHECK-SUBSEQUENCE
SI:CHECK-TYPER SI:CHECK-SUBSEQUENCER)
(*lexpr SEND))
#+(and MacLISP (not NIL))
(eval-when (eval load compile)
(cond ((status feature COMPLR)
(*lexpr SI:CHECK-SUBSEQUENCER SI:LOST-MESSAGE-HANDLER)
(*expr SI:CHECK-TYPER)))
)
;;;; CHECK-ARG and ERROR-RESTART are LISPM compatible
;;;; CHECK-TYPE and CHECK-SUBSEQUENCE
(defmacro CHECK-ARG (var pred string &optional type complainant)
(if (and (null type) (symbolp pred))
(setq type pred))
(if complainant (setq complainant `',complainant))
(let ((termin (cond ((symbolp pred) `(,pred ,var))
('T pred))))
`(DO ()
(,termin ,var)
(SETQ ,var (CERROR 'T () ':WRONG-TYPE-ARGUMENT
CHECK-ARG-CONTROL-STRING
',type ,var ',var ,string ,complainant)))))
(defvar CHECK-ARG-CONTROL-STRING
'|The ~2G~S argument ~4G~:[~;to ~4G~S ~]was ~1G~S, which is not ~3G~A|)
(defmacro ERROR-RESTART (&rest forms)
`(DO () (()) (*CATCH 'ERROR-RESTART (RETURN (PROGN ,.forms)))))
(defmacro CHECK-TYPE (var type-test-predicate using-function)
(cond ((and var (symbolp var)) () )
((fboundp 'si:check-typer)
(setq var (si:check-typer var #'SYMBOLP '|CHECK-TYPE MACRO|)))
('T (error '|Not a SYMBOL| var)))
`(SETQ ,var (SI:CHECK-TYPER ,var ,type-test-predicate ,using-function)))
(defmacro CHECK-SUBSEQUENCE ((seq start cnt) requisite-type using-function
&optional (startp 'T) (cntp 'T)
&rest rest)
(or (and seq (symbolp seq))
(setq seq (si:check-typer seq #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|)))
(or (and start (symbolp start))
(setq start (si:check-typer start #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|)))
(cond
((null cnt) (setq cntp () ))
((not (symbolp cnt))
(setq cnt (si:check-typer cnt #'SYMBOLP '|CHECK-SUBSEQUENCE MACRO|))))
`(MULTIPLE-VALUE (,seq ,start ,cnt)
(SI:CHECK-SUBSEQUENCER ,seq ,start ,cnt
,requisite-type ,using-function
,startp ,cntp ,. rest)))
;;;; SI:CHECK-TYPER and SI:CHECK-SUBSEQUENCER
;; Someday, pleas put in a 4th arg here, which is paralle to the
;; 'complainant' arg of CHECK-ARG. 11/26/80 JonL and RLB
(defun SI:CHECK-TYPER (argument type-test-predicate using-function)
(do ()
;; Basically, a funcall follows, but "beat-out-the-funcall" if possible
((cond ((eq type-test-predicate #'SI:NON-NEG-FIXNUMP)
(and (fixnump argument) (>= argument 0)))
((eq type-test-predicate #'SI:MAX-EXTEND-SIZEP)
(and (fixnump argument)
(>= argument 0)
(< argument #M 510. #-MacLISP 1_18.)))
((eq type-test-predicate #'PAIRP)
(pairp argument))
((eq type-test-predicate #'SYMBOLP)
(symbolp argument))
((eq type-test-predicate #'FIXNUMP)
(fixnump argument))
(T (funcall type-test-predicate argument))))
(setq argument
(cerror 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S does not pass the ~0G~S test, for function ~2G~S"
type-test-predicate argument using-function)))
argument)
(defun SI:CHECK-SUBSEQUENCER (seq start cnt requisite-type using-function
&optional (startp 'T)
(cntp 'T)
(forwardp 'T)
lispmp )
;;The 'lispm' argument only matters when 'forwardp' is null -- then
;; we need to know whether the 'start' index signifies the last index,
;; or (as on the LISPM) the last index plus one.
(let ((floating-type (null requisite-type))
len)
(do ()
((prog2 (cond (requisite-type)
;; Let the requisite-type "float" if it isn't supplied
((null seq) (setq requisite-type 'LIST))
('T (setq requisite-type (ptr-typep seq))
(if (eq requisite-type 'PAIR)
(setq requisite-type 'LIST))))
(memq requisite-type '(STRING VECTOR BITS LIST EXTEND))))
(if floating-type
(setq seq (cerror 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S (of ptr-TYPEP ~S) is not a sequence -- ~S"
'T seq requisite-type 'CHECK-SUBSEQUENCE)
requisite-type () )
(setq requisite-type
(cerror 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S is not a sequence type-name -- ~S"
'T requisite-type 'CHECK-SUBSEQUENCE))))
;; Loop while checking type of sequence argument
(do ()
((caseq requisite-type
(STRING (when (stringp seq)
(setq len (string-length seq))
'T))
(VECTOR (when (vectorp seq)
(setq len (vector-length seq))
'T))
(BITS (when (bitsp seq)
(setq len (bits-length seq))
'T))
(LIST (when (listp seq)
(setq len (length seq))
'T))
(EXTEND (when (extendp seq)
(setq len (extend-length seq))
'T))
(T (error 'CHECK-SUBSEQUENCE))))
(setq seq (cerror 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S must be a ~0G~S for function ~2G~S"
requisite-type seq using-function)))
;; Do defaulting on the start-index argument, if necessary, or
;; loop while checking it for being withing range
(if (or (not startp) (null start))
(setq start (if forwardp 0 (if lispmp len (1- len))))
(do ()
((and (fixnump start)
(or (and (>= start 0) ;Normal accessible element index
(< start len))
(and (>= start -1)
(<= start len)
;;For backwards searching, permit index to be one
;; greater than maximum legal for access.
(or (not forwardp)
;;Or a 0 cnt permits this kind of index too.
(or (and (fixnump cnt)
(= cnt 0))
(and (not cntp)
(= len 0))
))))))
(setq start (cerror 'T () ':INCONSISTENT-ARGUMENTS
"The 'start' index ~1G~S is not within ~2G~S, for function ~3G~S"
(list start seq) start seq using-function))))
;; Do defaulting on the number-of-items argument, if necessary, or
;; loop while checking start number-of-items argument
(if (or (not cntp) (null cnt))
(setq cnt (if forwardp (- len start) (if lispmp start (1+ start))))
(do ()
((cond ((or (not (fixnump cnt)) (< cnt 0)) () )
(forwardp (<= (+ start cnt) len))
('T (if lispmp (> start cnt) (>= start cnt)))))
(setq cnt (cerror 'T () ':INCONSISTENT-ARGUMENTS
"The 'count' value ~1G~S is out of range for ~2G~S,~% ~4G~:[bounded above by~;starting at~] index ~3G~S, and going in the ~4G~:[backward~;forward~] direction,~% from function ~5G~S"
(list seq start cnt (if forwardp '+ '-))
cnt seq start forwardp using-function))))
(values seq start cnt)))

577
src/nilcom/macaid.120 Executable file
View File

@@ -0,0 +1,577 @@
;;; MACAID -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** MacLISP ******* MACro definition AIDs *****************************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
(herald MACAID /120)
#-NIL
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload SHARPCONDITIONALS)
(subload LOOP)
)
;; For bootstrapping into LISPM, this could do
;; (defmacro HERALD (group-name &optional (version-number '?))
;; `(DEFPROP ,group-name ,version-number VERSION))
#+(or LISPM (and NIL (not MacLISP)))
(progn 'compile
(globalize "FLATTEN-SYMS") ; Functions supplied
(globalize "BUT-TAIL")
(globalize "SYMBOLCONC")
(globalize "no-funp/|")
(globalize "side-effectsp/|")
(globalize "constant-p/|")
(globalize "+INTERNAL-DUP-P")
(globalize "+INTERNAL-PERMUTIBLE-P")
(globalize "defmacro-2/|") ;standardize macro-defining format
(globalize "DEFSIMPLEMAC") ; Macros
(globalize "DEFCOMPLRMACRO")
(globalize "DEFBOTHMACRO")
(globalize "GENTEMP")
)
#-MacLISP (eval-when (eval compile load) (PACKAGE-DECLARE * SYSTEM 100) )
#-NIL
(subload DEFMAX) ;Get important functions and globalizations
#M
(eval-when (eval load compile)
(cond ((status feature COMPLR)
(*lexpr SYMBOLCONC GENTEMP)
(special GENTEMP)))
)
#+(local MacLISP)
(declare (own-symbol FLATTEN-SYMS |carcdrp/|| |no-funp/|| |side-effectsp/||
+INTERNAL-DUP-P DEFSIMPLEMAC DEFCOMPLRMAC SYMBOLCONC
DEFBOTHMACRO |no-funp/|| |constant-p/||))
#-NIL
(eval-when (eval compile)
#-LISPM (*expr |carcdrp/||)
(special |carcdrp/||)
(defmacro TYPECASEQ (&rest w)
`(CASEQ (TYPEP ,(car w))
,.(mapcar '(lambda (x)
(cons (sublis '((PAIR . LIST)) (car x))
(cdr x)))
(cdr w))))
#+LISPM (defmacro PAIRP (x) `(NOT (ATOM ,x)))
)
;;;; GENTEMP and SI:GEN-LOCAL-VAR
;;GENTEMP holds a list of three goodies
;; 1st: a string, or list of "chars", for the root "string" of the var names
;; 2nd: a number to be incremented with each usage, for a numerical suffix
;; 3rd: the marker used as a plist flag to signal "super-uninterned"
(or (and (boundp 'GENTEMP) GENTEMP)
(setq GENTEMP (list ".." 0. '+INTERNAL-TEMP-MARKER)))
(eval-when (eval compile)
(defmacro GENTEMP-prefix () `(CAR GENTEMP))
(defmacro GENTEMP-time () `(CADR GENTEMP))
(defmacro GENTEMP-marker () `(CADDR GENTEMP))
)
(defun GENTEMP (&optional (prefix () prefix-p) &aux (s0 (si:time-stamp)))
"Generate a temporary symbol, which is guaranteed to have no
'properties', even after compiling and fasloading."
(setq s0
#-NIL
(maknam (nconc (if prefix-p (exploden prefix) (list 'T))
(exploden (GENTEMP-prefix))
s0))
#+NIL
(si:symbol-cons (string-append (if prefix-p (to-string prefix) "T")
(GENTEMP-prefix)
s0))
)
(putprop s0 'T (GENTEMP-marker))
s0 )
(defmacro SI:GEN-LOCAL-VAR (&optional var (gentempper () gp))
"Basically, a GENTEMP with a :LOCAL-VAR property, so that the
COMPLR can check to see that it is never auto-SPECIALized."
(setq gentempper (cond (gentempper `(GENTEMP ,gentempper))
('(GENTEMP))))
(cond ((and gp (null var)) gentempper)
(var `(PROG2 (PUTPROP (SETQ ,var ,gentempper) 'T ':LOCAL-VAR)
,var))
((let ((g (gentemp)))
(putprop g 'T ':LOCAL-VAR)
`((LAMBDA (,g)
(PUTPROP ,g 'T ':LOCAL-VAR)
,g)
,gentempper)))))
(defun SI:TIME-STAMP ()
"For now, this is just a sequence of numbers stored in a slot of GENTEMP.
But we need a real 'time-stamp', such as the number of milliseconds since
Jan 1, 1970."
(setf (GENTEMP-time) (1+ (GENTEMP-time)))
#-NIL
(let ((BASE 10.) (*NOPOINT 'T)) (exploden (GENTEMP-time)))
#+NIL
(fill-digits-into-string (make-string 12.)
(GENTEMP-time)
0
12.
36.))
;;;; DEFSIMPLEMAC
;;; Many functions of one argument can be macro-expanded, providing
;;; that the argument-form can be multiplied. If not, then we must
;;; wrap a LAMBDA around it, and give it an argument-form of a symbol.
(defmacro DEFSIMPLEMAC (oname vars /&rest body &aux var name)
(and (or (atom vars) (not (symbolp (car vars))) (cdr vars))
(error "Bad arglist for DEFSIMPLEMAC" `(,oname ,vars ,@body)))
(setq var (car vars))
(if (not (pairp oname))
(setq oname `(,oname DEFMACRO-DISPLACE-CALL 'T)))
(setq name (car oname)
body `(DEFMACRO ,oname ,vars
(COND ((and (|no-funp/|| (SETQ ,VAR (MACROEXPAND ,VAR)))
(+INTERNAL-DUP-P ,VAR))
,(cond ((cdr body) (cons 'PROGN body))
((car body))))
('T (|non-simple-x/|| ',name ,VAR)))))
#-NIL (if (if (get 'SHARPCONDITIONALS 'VERSION)
(nofeaturep 'NIL)
(status feature NIL))
(setq body `(PROGN 'COMPILE
(DEF-OR-AUTOLOADABLE |non-simple-x/|| MACAID)
,body)))
body)
;; Presumes that argument is already macroexpanded
(defun |non-simple-x/|| (name callarg)
(cond ((eq (car callarg) 'PROG2)
(let (( (() e1 e2 . rst) callarg))
`(PROG2 ,e1 (,name ,e2) ,. rst )))
((eq (car callarg) 'PROGN)
(setq callarg (reverse (cdr callarg)))
`(PROGN ,.(nreverse (cdr callarg))
(,name ,(car callarg))))
((memq (car callarg) '(SETQ PSETQ))
`(PROG2 ,callarg (,name ,(cond ((eq (car callarg) 'PSETQ)
(cadr callarg))
((do ((l (cdr callarg) (cddr l)))
((null (cddr l)) (car l))))))))
((let (g decls)
(si:gen-local-var g)
(if (and (not (atom callarg))
(memq (car callarg) '(FIXNUM-IDENTITY FLONUM-IDENTITY)))
(setq decls `((DECLARE
(,(if (eq (car callarg) 'FIXNUM-IDENTITY)
'FIXNUM
'FLONUM)
,g)))
callarg (cadr callarg)))
`((LAMBDA (,g) ,.decls (,name ,g)) ,callarg)))))
;;;; DEFBOTHMACRO and DEFCOMPLRMAC
(defmacro DEFBOTHMACRO (fun &rest w &aux args body simplep)
(setq args (car w) body (cdr w)) ;Remember! LISPM is stupid
(if (eq args 'SIMPLE)
(setq args (car body) body (cdr body) simplep 'T))
(setq body (progv args args (mapcar #'EVAL body))) ;like a macro expansion
`(PROGN 'COMPILE
(DEFCOMPLRMAC ,fun ,.w)
(DEFUN ,fun ,args ,.body)))
(defmacro DEFCOMPLRMAC (&rest w)
(let (((fun args . body) w)
(defmac 'DEFMACRO))
(or (symbolp fun) (error "Name not a symbol -- DEFCOMPLRMAC" fun))
(cond ((eq args 'SIMPLE)
(pop body args)
(setq defmac 'DEFSIMPLEMAC)))
(if (fboundp 'MACRO-EXPAND)
(setq body (cdr (macro-expand `(PROGN ,.body)))))
#-NIL
;;In the MacLISP case, we don't use the SOURCE-TRANS feature, since
;; we dont want to clutter up the address space of a non-COMPLR
;; environment with all those crufty expansion subrs
(let ((definer `(,DEFMAC ,fun ,args ,.body)))
`(PROGN 'COMPILE
(EVAL-WHEN (LOAD)
(COND ((STATUS FEATURE COMPLR)
(DEFPROP ,fun T DEFCOMPLRMAC)
(EVAL ',definer))))
(EVAL-WHEN (EVAL COMPILE)
,definer)))
#+NIL
(let ((expander-fun (si:gen-local-var))
DEFMACRO-CHECK-ARGS DEFMACRO-DISPLACE-CALL )
;; process the &optional, &rest, and &aux of args for a LET list
(desetq (() () args . body) (|defmacro-2/|| w))
;; 'args' should now be a list of one symbol.
`(PROGN 'COMPILE
(DEFUN ,expander-fun ,args
(VALUES (PROGN ,.body) 'T))
(PUSH ',expander-fun (GET ',fun 'SOURCE-TRANS))))
))
#-MacLISP
(defun |defmacro-2/|| (x &aux (y x) name)
"Will standardize a macro definition into the primitive (MACRO ...) form."
(if (cond ((not (pairp x)))
((memq (car x) '(DEFUN MACRO)) () )
((memq (car x) '(DEFMACRO DEFMACRO-DISPLACE))
(setq y (|defmacro-1/|| x ddc))
(if (eq (car y) 'PROGN)
(or (setq y (assq 'MACRO (cdr x)))
(setq y (assq 'DEFUN (cdr x)))))
(if (and y (eq (car y) 'DEFUN))
(setq y (cond ((eq (setq name (caddr y)) 'MACRO)
;; (DEFUN <name> MACRO (ARG) ...)
`(MACRO ,(cadr y) ,.(cdddr y)))
((memq name '(EXPR FEXPR)) () )
(y))))
(null y)))
(+internal-lossage 'DEFUN '|defmacro-2/|| x))
(cond ((and (eq (car y) 'MACRO) (symbolp (cadr y)))
y)
('T (setq name (cadr y))
(if (pairp name) (setq name (car name)))
`(MACRO ,name ,(cddr y)))))
;;;; |carcdrp/||
#-NIL (progn 'COMPILE
; +INTERNAL-CARCDRP returns a -1 if arg is not a carcdr symbol, else returns
; a 13.-bit number encoding the three things of the old carcdr property.
(defun |carcdrp/|| (x)
(cond ((get x 'CARCDR))
(|carcdrp/|| ;|carcdrp/|| is non-null iff
(let ((n (+INTERNAL-CARCDRP x))) ; +INTERNAL-CARCDRP exists
(declare (fixnum n nn))
(cond ((< n 0) () )
((putprop x ;"cache" result on plist
(list* (cond ((< n 1_12.) 'A) ('D))
(implode
`(C ,.(nconc
(do ((z ()
(cons (cond ((zerop (boole 1 nn 1))
'A)
('D))
z))
(nn (boole 1 (lsh n -6) 63.)
(lsh nn -1)))
((< nn 2) z))
'(R))))
(boole 1 n 63.))
'CARCDR)))))))
(and (not (boundp '|carcdrp/||))
(not (setq |carcdrp/|| (fboundp '+INTERNAL-CARCDRP)))
(mapc '(lambda (x) (putprop (car x) (cdr x) 'CARCDR))
'((CAR (A NIL . 6.))
(CAAR (A CAR . 5.))
(CAAAR (A CAAR . 19.))
(CAAAAR (A CAAAR . 27.))
(CAAADR (A CAADR . 26.))
(CAADR (A CADR . 18.))
(CAADAR (A CADAR . 17.))
(CAADDR (A CADDR . 16.))
(CADR (A CDR . 4.))
(CADAR (A CDAR . 3.))
(CADAAR (A CDAAR . 36.))
(CADADR (A CDADR . 35.))
(CADDR (A CDDR . 2.))
(CADDAR (A CDDAR . 1.))
(CADDDR (A CDDDR . 0.))
(CDR (D NIL . 14.))
(CDAR (D CAR . 13.))
(CDAAR (D CAAR . 24.))
(CDAAAR (D CAAAR . 33.))
(CDAADR (D CAADR . 32.))
(CDADR (D CADR . 23.))
(CDADAR (D CADAR . 22.))
(CDADDR (D CADDR . 21.))
(CDDR (D CDR . 12.))
(CDDAR (D CDAR . 11.))
(CDDAAR (D CDAAR . 30.))
(CDDADR (D CDADR . 29.))
(CDDDR (D CDDR . 10.))
(CDDDAR (D CDDAR . 9.))
(CDDDDR (D CDDDR . 8.)) )
))
)
#+NIL
(defun |carcdrp/|| (x)
(let* ((pn (get-pname x))
(len (string-length pn)))
(and (> len 2)
(eq (char pn 0) ~C)
(eq (char pn (1- len)) ~R)
(LOOP FOR i FROM (- len 2) DOWNTO 1
UNLESS (memq (char pn i) '(~A ~D)) RETURN ()
FINALLY (return 1000.)))))
;;;; |constant-p/||, |no-funp/||, and +INTERNAL-DUP-P,
;; Presumes that argument is already macroexpanded
(defun |constant-p/|| (x)
(or (null x)
(typecaseq x
(SYMBOL () )
(PAIR (memq (car x) '(QUOTE FUNCTION)))
(T 'T))))
;; Presumes that argument is already macroexpanded
(defun |no-funp/|| (x)
(cond ((or (atom x) (memq (car x) '(QUOTE FUNCTION DECLARE))))
((not (symbolp (car x))) () )
((|carcdrp/|| (car x)) (|no-funp/|| (cadr x)))
((memq (car x) '(NTH FIXNUM-IDENTITY FLONUM-IDENTITY
+INTERNAL-CHAR-N CHAR-N CHAR VREF BIT
SI:XREF CXR ELT AR-1 AREF))
(and (|no-funp/|| (cadr x)) (|no-funp/|| (caddr x))))
((memq (car x) '(+ - * // \ 1+ 1- +$ -$ *$ //$ 1+$ 1-$))
(LOOP FOR y IN (cdr x)
ALWAYS (|constant-p/|| y)))))
;; Presumes that argument is already macroexpanded
(defun +INTERNAL-DUP-P (x)
"Non-null if it is 'cheaper' to duplicate the permissibly-duplicatable
code rather than do a lambda-binding."
(cond ((or (atom x) (memq (car x) '(QUOTE FUNCTION DECLARE)))
;; These, of course, do nothing
'T)
((not (symbolp (car x))) () )
((|carcdrp/|| (car x))
;; any carcdr of length 2 or less -- '(CAR CDR CAAR CADR CDAR CDDR)
(and (< (flatc (car x)) #-NIL 4 #+NIL 3)
(or (atom (cadr x))
(|constant-p/|| (cadr x)))))
#M
((eq 'CXR (car x))
(and (|constant-p/|| (cadr x))
(or (atom (caddr x)) (|constant-p/|| (caddr x)))))
((memq (car x) '(+ - * // \ 1+ 1- +$ -$ *$ //$ 1+$ 1-$))
(LOOP FOR y IN (cdr x)
ALWAYS (|constant-p/|| y)))
((or (memq (car x) '(FIXNUM-IDENTITY FLONUM-IDENTITY))
(and (null (cddr x)) (memq (car x) '(PROG2 PROGN))))
(+internal-dup-p (cadr x)) )))
(defun +INTERNAL-PERMUTIBLE-P (forms)
"Non-null if it is permissible to change the ordering of the
evaluations on the list 'forms'."
(do ((l forms (cdr l)) ;Either all constans
(non-constantsp) ; or no side-effects
(haumany-sides 0)
x)
((null l) 'T)
(declare (fixnum haumany-sides))
(setq x (macroexpand (car l)))
(cond ((|constant-p/|| x) () )
((|side-effectsp/|| x)
(if (or non-constantsp (> haumany-sides 0))
(return () ))
(setq non-constantsp 'T
haumany-sides (1+ haumany-sides))
(if (> haumany-sides 1) (return () )))
('T (setq non-constantsp 'T)))))
;;;; |side-effectsp/||
(defun |side-effectsp/|| (x)
(cond ((atom x) () )
((memq (car x) '(QUOTE FUNCTION DECLARE)) () )
((and (pairp (car x)) (eq (caar x) 'LAMBDA))
(or (|mmcdrside/|| (cdar x)) (|mmcdrside/|| x)))
((or (not (symbolp (car x))) (not (fboundp (car x))))
'T)
#+LISPM
((let (ocarx ocdrx nx)
(setq ocarx (car x) ocdrx (cdr x))
(setq nx (macroexpand-1 x))
(cond ((or (not (eq nx x))
(not (eq ocarx (car x)))
(not (eq ocdrx (cdr x))))
(setq x nx)
'T)))
(|side-effectsp/|| x))
#-LISPM
((multiple-value-bind (nx ex?) (macroexpand-1*m x)
(if ex? (setq x nx))
ex?)
(|side-effectsp/|| (car x)))
((get (car x) '|side-effectsp/||) (|mmcdrside/|| x))
((|carcdrp/|| (car x)) (|side-effectsp/|| (cadr x)))
((eq (car x) 'COND)
(LOOP FOR clause IN (cdr x)
THEREIS (|mmcdrside/|| (cons () clause))))
((memq (car x) '(CASEQ SELECTQ))
(or (|side-effectsp/|| (cadr x))
(LOOP FOR z IN (cddr x)
THEREIS (|mmcdrside/|| z))))
((eq (car x) 'PROG) (|mmcdrside/|| (cdr x)))
('T 'T)))
(defun |mmcdrside/|| (y)
(LOOP FOR x IN (cdr y)
THEREIS (|side-effectsp/|| x)))
;; This property does not mean that the function has side effects! It
;; means that the function itself has none, but that it's arguments should
;; be inspected by means of the function |mmcdrside/||
(mapc '(lambda (x) (putprop x '|mmcdrside/|| '|side-effectsp/||))
(append
#M '(ARRAYCALL ARRAY LISTARRAY HUNK MAKHUNK CXR
SIGNP *LDB *LOAD-BYTE ROT FSC |&restv-ify/|| )
#N '( <$ >$ <=$ >=$ =$ MAX& MIN& MAX$ MIN$ ELT)
'(SI:MAKE-EXTEND SI:EXTEND-LENGTH SI:EXTENDP EXTENDP EXTEND-LENGTH
SI:XREF SI:EXTEND PTR-TYPEP +INTERNAL-CHAR-N)
'(STRINGP VECTORP BITSP CHARACTERP
SUBSEQ TO-LIST TO-VECTOR TO-STRING TO-BITS
VECTOR-LENGTH STRING-LENGTH BITS-LENGTH
BIT VREF CHAR CHAR-N +INTERNAL-CHAR-N
VECTOR MAKE-VECTOR MAKE-STRING MAKE-BITS
*:FIXNUM-TO-CHARACTER STRING-PNPUT
|defvst-construction/|| |defvst-construction-1/||
|defvst-selection-1/|| |defvst-xref/||
;; above are for NILCOM stuff
AND OR MAKNAM MAKE-LIST PAIRP FBOUNDP PLIST
CONS NCONS XCONS ASSQ ASSOC COPYSYMBOL GET GETL
GETCHAR GETCHARN IMPLODE LAST LIST LISTIFY PNGET
EXPLODE EXPLODEC EXPLODEN FLATC FLATSIZE BUT-TAIL
MEMQ MEMBER SUBLIS SUBST REVERSE APPEND SYMBOLCONC
BIGP EQUAL EQ FIXP FLOATP NUMBERP SYMBOLP TYPEP
NOT NULL ODDP GREATERP LESSP PLUSP MINUSP ZEROP
FILEP FASLP PROBEF NAMELIST NAMESTRING TRUENAME
PLUS DIFFERENCE TIMES QUOTIENT ADD1 SUB1 ABS
+ - * // 1+ 1- ^ +$ -$ *$ //$ 1+$ 1-$ ^$ \ \\
REMAINDER GCD EXP EXPT BOOLE > < = >= <=
IFIX FIX LOG SQRT SIN COS LSH ASH LDB LOAD-BYTE
HAIPART HAULONG HUNKSIZE LENGTH SXHASH
FIXNUM-IDENTITY FLONUM-IDENTITY)
))
;;;; SYMBOLCONC, BUT-TAIL, FLATTEN-SYMS
(eval-when (eval compile)
(defmacro iterate-over-args (varsl &rest body &aux item seq index tail)
(pop varsl item) ;Damnd LISPM! really want
(pop varsl seq) ; (desetq (item seq index tail) varsl)
(pop varsl index)
(pop varsl tail)
#-NIL `(LOOP FOR ,tail ON ,seq
AS ,item = (car ,tail)
FOR ,index FROM 0
DO ,.body)
#+NIL `(LOOP FOR ,item BEING THE VECTOR-ELEMENTS OF ,seq USING (INDEX ,index)
DO ,.body) ))
(defun SYMBOLCONC #M w #-MacLISP (&rest w &aux (nchars 0))
"Concatenate together the PNAMEs of some SYMBOLs, and INTERN that
string to get a SYMBOL."
#M (setq w (listify w))
(iterate-over-args (s w i l)
(do ()
((cond
((null s)
(setq s #-MacLISP (make-string 0) ;FOo! () means different
#+MacLISP (list #/N #/I #/L) ; things at times!
)
'T)
((typecaseq s
(SYMBOL (setq s #M (exploden s) #-MacLISP (get-pname s)) 'T)
(FIXNUM #-LISPM
(let ((BASE 10.)
(*NOPOINT 'T))
(setq s (exploden s))
#-MacLISP
(setq s (to-string s)))
#+LISPM (setq s (string s)))
(PAIR (setq s #N (to-string s)
#M (append s () )
#Q (apply #'STRING-APPEND s)
)
'T)
#-MacLISP (STRING 'T)
#N (VECTOR (setq s (to-list s)))
(T #M (cond ((not (hunkp s)) () )
((and (fboundp 'STRINGP) (stringp s))
(setq s (exploden s))
'T)
((and (fboundp 'VECTORP) (vectorp s))
(setq s (to-list s))
'T))
#-MacLISP () )))))
(setq s (cerror 'T () ':WRONG-TYPE-ARGUMENT
"~1G~S Bizarre arg -- SYMBOLCONC"
'SYMBOL s)))
#+NIL (prog2 (setq nchars (+ nchars (string-length s)))
(vset w i s))
#-NIL (rplaca l s)
)
#Q (intern (apply #'STRING-APPEND w))
#M (implode (apply 'NCONC w))
#N (let ((result (make-string nchars)) ;Since this file is early
(newi 0)) ; in the bootstrapping of
(iterate-over-args (s w i () ) ; the system, make sure it
(string-replace result s newi) ; uses only simple things.
(setq newi (+ newi (string-length s))))
(intern result))
)
(defun BUT-TAIL (list tail)
"Copy top level of list l down to the tail of l that is EQ to tail."
#+Lispm (ldiff list tail)
#-Lispm
(do ((l list (cdr l))
(copy () (cons (car l) copy)))
((or (atom l) (eq l tail)) (nreverse copy)))
)
(defun FLATTEN-SYMS (x l)
"Descend a pair tree, collecting a list of all SYMBOLs seen."
(cond ((pairp x) (FLATTEN-SYMS (car x) (FLATTEN-SYMS (cdr x) l)))
((null x) l)
((symbolp x) (cons x l))
('T l)))

564
src/nilcom/setf.293 Executable file
View File

@@ -0,0 +1,564 @@
;;; SETF -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** NIL ******** SETF, PUSH, and POP Expanders ***********************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
(herald SETF /293)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((LISP) SUBLOAD)))
(subload SHARPCONDITIONALS)
)
#+(local MacLISP)
(eval-when (compile)
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(SETF +INTERNAL-SETF-X +INTERNAL-SETF-X-1 SETF-SIMPLEP-SCAN
+INTERNAL-CARCDR-SETF +INTERNAL-PUSH-X +INTERNAL-POP-X
DEFUPDATE PUSH POP))
)
#+(or NIL LISPM)
(progn
(globalize "+INTERNAL-SETF-X")
(globalize "+INTERNAL-POP-X")
(globalize "+INTERNAL-SETF-X-1")
(globalize "+INTERNAL-PUSH-X")
(globalize "+INTERNAL-CARCDR-SETF")
(globalize "SETF-SIMPLEP-SCAN")
(globalize "SETF-STRUCT")
(globalize "SETF")
(globalize "DEFUPDATE")
(globalize "STATIC-AREAP")
(globalize "WRITEABLEP")
)
;;; Current contents:
;;; Functions: +INTERNAL-SETF-X, +INTERNAL-SETF-X-1, +INTERNAL-CARCDR-SETF
;;; +INTERNAL-PUSH-X, +INTERNAL-POP-X, DEFUPDATE
;;; and defsetfs for various functions
#-NIL
(eval-when (eval compile)
(subload MACAID)
;; Following will also load VECTOR and DEFVST at eval-compile times
(subload EXTMAC)
(subload EXTEND)
(subload DEFSETF)
(subload EVONCE)
)
#M (eval-when (eval load compile)
(and (status feature COMPLR)
(*lexpr EVAL-ORDERED* SETF-STRUCT))
)
;;Well, when can we take this out? -- JonL, 12/23/80
#N (progn 'compile
(defmacro STATIC-AREAP (&rest l) '() )
(defmacro STATIC-COPY (x) x)
)
#-NIL (progn 'compile
(defmacro STATIC-AREAP (x)
#+PDP10 `(PUREP ,x)
#-PDP10 '() )
(defmacro STATIC-COPY (x)
#+PDP10 `(PURCOPY ,x)
#-PDP10 '() )
)
#+(and MacLISP PDP10) (progn 'compile
(def-or-autoloadable PUREP PUREP)
(def-or-autoloadable WRITEABLEP PUREP)
(def-or-autoloadable LEXPR-FUNCALL LEXPRF)
(def-or-autoloadable EVAL-ORDERED* EVONCE)
(def-or-autoloadable GENTEMP MACAID)
)
;;;; Comments
;; There are problems with doing PUSH and POP regarding multiple evaluations
;; of the computation yielding the stack. Simply expanding into SETF
;; results in unobvious order-of-evaluation and multiple evaluation, and
;; the wrong return result.
;; To deal with this, we interrupt the SETF expansion midway, after all
;; the pieces have been picked apart. The setf expanders for the various
;; functions provide us with a structure containing the computations required,
;; the value to be stored, and continuation functions to apply to the
;; computations to get the forms to store and retrieve the value. This lets
;; us substitute gensyms for computations that we decide should not be repeated
;; and lambda-bind the gensyms to the computations.
;; The components of the setf-struct are as follows
;; * SETF-compute A list (who's length we'll call "n")
;; of forms to be EVAL'ed in the
;; computation prior to storing the
;; value.
;; SETF-i-compute A copy of the initial value of
;; SETF-compute
;; SETF-side-effects A flag, non-null if SETF-SIMPLEP-SCAN
;; encountered any expressions which may
;; have contained side effects.
;; Initially ().
;; * SETF-access A function of n arguments, to be APPLYd
;; to the applied to the computations
;; to give a form to access the
;; specified slot of the structure
;; given the computations with whatever
;; gensym substitutions performed.
;; * SETF-invert A function of n+1 arguments, to be
;; applied to SETF-allcomps
;; * SETF-ret-ok A flag, non-null implies form returned
;; by SETF-invert will be the value of
;; the SETF-value-expr
;; SETF-genvals A list of values for which gensym
;; been substituted for in SETF-compute.
;; SETF-gensyms A list of gensyms, one-to-one with
;; values in SETF-genvals
;; SETF-user-slot A slot available for communication
;; between SETF-X expanders and their
;; continuations (INVERT and ACCESS)
;; These objects are returned by +INTERNAL-SETF-X-1. They are updated by
;; SETF-SIMPLEP-SCAN to build the SETF-genvals and SETF-gensyms slots, from
;; which a lambda form can be wrapped around the accessing and setting.
;; The user of the structure is responsible for remembering the value to
;; be stored, and possibly substituting a gensym for it in the lambda form.
;; The slots marked above with a "*" are supplied by calling the SETF-X
;; property on the X part of (SETF X Y). (the case of X being a symbol
;; is special-cased, and the CAR/CDR cases are handled specially if no
;; SETF property is found.)
;; (SETF-STRUCT access invert ret-ok compute)
;; creates one of these SETF structures. The value component is
;; Note: The variable EFFS herein is not special. It is, however, equivalent
;; in function to the compiler's (NCOMPLR and LCP) variable EFFS. If non-(),
;; the form is being expanded "for effect", i.e. the return value is going to b
;; ignored, so don't bother taking pains to preserve it. It is supplied as ()
;; in the interpreter, and currently in the compiler as well.
;; +INTERNAL-PUSH-X and +INTERNAL-POP-X are called by the interpreter and
;; compiler to expand complex PUSH and POPs. The first argument is the
;; CDR of the PUSH or POP form (viewed as a macro, or the entire argument
;; to the PUSH or POP FSUBR in the interpreter). The second is the
;; EFFS argument as above.
;; (DEFMACRO PUSH (&REST PUSH-ARGS) `(+INTERNAL-PUSH-X ,PUSH-ARGS () ))
;; (DEFMACRO POP (&REST POP-ARGS) `(+INTERNAL-POP-X ,POP-ARGS () ))
;;;; +INTERNAL-PUSH-X and +INTERNAL-POP-X
(defmacro DEFUPDATE (name conser)
`(DEFMACRO ,name (&WHOLE FORM)
(+INTERNAL-PUSH-X (CDR FORM)
() ;Losing compiler doesn't hack EFFS
;at macro-expansion time.
',conser)))
;; example: (defupdate PUSH CONS)
;; (defupdate accumulate PLUS)
;; (defmacro increment (x) `(accumulate 1 ,x))
(defun +INTERNAL-PUSH-X ((val stack) effs &optional (push-cons 'CONS)
&aux valval valsym temp incrementation)
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () )))
(cond ((and (not (|constant-p/|| val))
(not (null (SETF-gensyms expf-stack))))
(setq valval (ncons val)
valsym (ncons (si:gen-local-var val)))))
(setq incrementation `(,push-cons ,val ,(setf-access-form expf-stack)))
(cond ((or effs (SETF-ret-ok expf-stack))
(setq temp (setf-invert-form expf-stack incrementation)))
('T (si:gen-local-var temp)
(setq temp
`((LAMBDA (,temp)
,(setf-invert-form expf-stack temp)
,temp)
,incrementation))))
(cond ((null (SETF-gensyms expf-stack)) temp)
('T `((LAMBDA (,@valsym ,.(SETF-gensyms expf-stack))
,temp)
,.valval ,.(SETF-genvals expf-stack))))))
;; POP must be careful of side-effect interactions between first and second arg
(defun +INTERNAL-POP-X (foo effs &optional (pop-car 'CAR) (pop-cdr 'CDR)
&aux (stack (car foo)) (into (cdr foo)))
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () ))
(expf-into (and (not (null into)) (+internal-setf-x-1 (car into))))
stack-access-form temp tsym )
(if into (setf-simplep-scan expf-into (SETF-side-effects expf-stack) ))
(cond ((or (not (null (SETF-gensyms expf-stack)))
(and into (SETF-side-effects expf-into)))
(si:gen-local-var tsym)
(setq temp `((CAR ,tsym)))
(if (and (not effs) ;Maybe save ret value
(not (SETF-ret-ok expf-into)))
(setq temp `((SETQ ,tsym ,@temp))))
(cond (into
(if (and (SETF-side-effects expf-into)
(not (SETF-side-effects expf-stack)))
(setf-simplep-scan expf-stack 'T))
(setq temp
(ncons (setf-invert-form expf-into (car temp))))))
(if (and (not effs)
(not (SETF-ret-ok expf-into))) ;Maybe need ret value
(setq temp `(,@temp ,tsym)))
`((LAMBDA (,.(SETF-gensyms expf-stack)
,.(and into (SETF-gensyms expf-into)))
((LAMBDA (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
,@temp)
,(setf-access-form expf-stack)))
,.(SETF-genvals expf-stack)
,.(and into (SETF-genvals expf-into))))
((+internal-dup-p
(setq stack-access-form (setf-access-form expf-stack)))
(setq temp `(,pop-car ,stack-access-form))
(cond ((not (null into)) ;Better code with SETQ inside PROG2
(setq temp
(+internal-setf-x `(,(car into) ,temp) effs))))
`(PROG2 ()
,temp
,(setf-invert-form expf-stack `(,pop-cdr ,stack-access-form))))
('T (si:gen-local-var tsym)
(setq temp `((LAMBDA (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
(,pop-car ,tsym))
,stack-access-form))
(if into
(+internal-setf-x `(,(car into) ,temp) effs)
temp)))))
;;;; SETF macro, +INTERNAL-SETF-X, and SETF-SIMPLEP-SCAN
(defmacro SETF (&rest w) (+internal-setf-x w () ))
(defun +INTERNAL-SETF-X (w effs)
(do ((l w (cddr l))
(form) (val) (expf) (val-gensym) (ret-form))
((null l)
(cond ((null (cdr ret-form)) (car ret-form))
('T `(PROGN ,. (nreverse ret-form)))))
;One step in expanding "(SETF ... form val ... )"
(desetq (form val) l)
(if (null (cdr l))
(setq val (cerror T () ':WRONG-NUMBER-OF-ARGUMENTS
"SETF called with an odd number of arguments. ~@
Extra reference = ~3G~S.~@
Supply a form to evaluate, store and return."
'SETF (length w) w form)))
(setq expf (+INTERNAL-SETF-X-1 form))
(cond ((or (and (null (cddr l)) ;If at end of SETF
(not effs) ;If values matter at all
(not (SETF-ret-ok expf)) ;If it wrong val at end
(not (+internal-dup-p val))) ;And we can't duplicate
(not (equal (SETF-compute expf) ;If already simplified
(SETF-i-compute expf))))
(if (equal (SETF-compute expf)
(SETF-i-compute expf))
(setf-simplep-scan expf () ))
(si:gen-local-var val-gensym)
(push `((lambda (,@(SETF-gensyms expf) ,val-gensym)
,(setf-invert-form expf val-gensym)
,val-gensym)
,@(SETF-genvals expf) ,val)
ret-form))
('T (setq ret-form (cons (setf-invert-form expf val)
ret-form))
(cond ((and (not effs)
(not (cddr l))
(not (SETF-ret-ok expf)))
(setq ret-form (cons val ret-form))))))))
;; Call SETF-SIMPLEP-SCAN on a SETF-STRUCT, and a second arg saying whether
;; or not side effects have been detected.
;; NO-OP if SETF-SIMPLEP-SCAN already called on it.
(defun SETF-SIMPLEP-SCAN (expf known-side-effects?)
(if (null (SETF-gensyms expf))
(do ((rest (SETF-compute expf) (cdr rest))
(clist) (slist) (sitem)
(original) (expansion))
((null rest)
(SSETF-genvals expf (nreverse clist))
(SSETF-gensyms expf (nreverse slist)))
(setq expansion (macroexpand (setq original (car rest))))
;; Why isn't the following RPLACA conditionalized by
;; (cond ((not (static-areap original)))
;; ((writeablep original)
;; ;; Writeable, but 'static', so someday may be purified.
;; (setq expansion (static-copy expansion))
;; 'T))
(rplaca rest expansion)
(cond ((or (|constant-p/|| expansion) ;Always safe!
(and (null known-side-effects?)
(+internal-dup-p expansion)))
;; Nothing to be done in these cases
() )
((and (null known-side-effects?) (|side-effectsp/|| expansion))
;;All is in, so reset and carefully do it again!
(SSETF-compute expf (append (SETF-I-compute expf) () ))
(SSETF-side-effects expf 'T)
(return (setf-simplep-scan expf 'T)))
('T (si:gen-local-var sitem)
(push expansion clist)
(push sitem slist)
(rplaca rest sitem)))))
expf)
;;;; +INTERNAL-SETF-X-1 and +INTERNAL-CARCDR-SETF
;; +INTERNAL-SETF-X-1 takes an access expression and returns a SETF-STRUCT
;; which contains the various info documented at the head of this file.
;; The way the expansion happens is a loop of the following:
;; a) If it's a symbol, special case
;; b) If the CAR is a symbol, and has a SETF-X property, FUNCALL it on the
;; access and value expressions (unless that property is 'AUTOLOAD',
;; meaning that autoloading should be tried if possible, or if it is
;; 'SETF-X' meaning autoloading has been tried and lost).
;; c) If it's a macro, MACROEXPAND-1 it and return
(defun +INTERNAL-SETF-X-1 (expr)
(prog (temp oper)
A (cond ((atom expr)
(cond ((symbolp expr)
(return (SETF-STRUCT `(LAMBDA (()) ',expr)
`(lambda (() y) `(setq ,',expr ,y))
'T
() )))))
((not (symbolp (setq oper (car expr)))) () )
((and (setq temp (get oper 'SETF-X))
(not (memq temp '(AUTOLOAD SETF-X))))
(return (funcall temp expr)))
('T (cond ((and (cond ((null temp)
;;This excludes carcdrs ??
(not (fboundp oper)))
((eq temp 'AUTOLOAD))) ;Help for LDB etc
(setq temp (get oper 'AUTOLOAD)))
(funcall autoload `(,oper . ,temp))
(cond ((setq temp (get oper 'SETF-X))
(return (funcall temp expr)))
('T (putprop oper 'SETF-X 'SETF-X))))
((setq temp (macroexpand-1* expr))
;allow macro-redefinition, even for carcdr functions
(return (+INTERNAL-SETF-X-1 (car temp))))
((setq temp (|carcdrp/|| oper))
(return (+INTERNAL-carcdr-setf temp expr))))))
(setq expr (error '|Obscure format - SETF| expr 'WRNG-TYPE-ARG))
(go A)
))
(defun +INTERNAL-CARCDR-SETF (carcdrspec expr)
(let ((rplac (cond ((eq (car carcdrspec) 'A) 'rplaca)
('T 'rplacd)) )
(op (cond ((eq (car carcdrspec) 'A) 'CAR)
('T 'CDR)))
(carcdr (cadr carcdrspec) )
((() pair) expr)
(subform) )
(setq subform (cond ((or (null carcdr) (eq carcdr 'CR)) pair)
('T `(,carcdr ,pair))))
(SETF-STRUCT `(LAMBDA (() X) `(,',op ,x))
`(LAMBDA (() VALUE PAIR) `(,',rplac ,pair ,value))
()
`(,subform))))
(defun setf-invert-form (expf val)
(lexpr-funcall (SETF-invert expf)
expf
val
(SETF-compute expf)))
(defun setf-access-form (expf)
(lexpr-funcall (SETF-access expf)
expf
(SETF-compute expf)))
; SETF-STRUCT is a slight variant on the constructor function
(defun SETF-STRUCT (access invert ret-ok compute &optional function)
(CONS-A-SETF COMPUTE compute
I-COMPUTE (APPEND compute ())
RET-OK ret-ok
ACCESS access
INVERT invert
FUNCTION function))
;;;; DEFSETFs for various system functions
(defsetf CXR ((() index frob) value) ()
`(RPLACX ,index ,frob ,value))
(defsetf NTH ((() index frob) value) ()
`(RPLACA (NTHCDR ,index ,frob) ,value))
(defsetf NTHCDR ((() index frob) value) ()
`(RPLACD (NTHCDR (1- ,index) ,frob) ,value))
;; The PROGN stuff isn't optimal, it will generate LAMBDAs unnecessarily.
;; Hopefully the compiler will eliminate them.
(defprop PROGN T SETF-PROGNP)
(defun (progn SETF-X-ACCESS) (expf &restl steps)
(let (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'SETF-PROGNP))
(setf-access-form expf-frobref)
`(,fun ,@steps ,(setf-access-form expf-frobref)))))
(defun (progn SETF-X-INVERT) (expf val &restl steps)
(let* (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'SETF-PROGNP))
(setf-invert-form expf-frobref val)
`(,fun ,@steps ,(setf-invert-form expf-frobref val)))))
(defun (progn SETF-X)
(expr &aux (fun (car expr)) temp frobref steps expf expf-frobref)
(setq temp (reverse (cdr expr))
frobref (car temp)
steps (nreverse (cdr temp))
expf (setf-simplep-scan
(setf-struct #,(get 'PROGN 'SETF-X-ACCESS)
#,(get 'PROGN 'SETF-X-INVERT)
()
steps)
() )
expf-frobref (setf-simplep-scan (+internal-setf-x-1 frobref) () ))
(SSETF-user-slot expf (list* fun expf-frobref))
(SSETF-genvals expf (append (SETF-genvals expf)
(SETF-genvals expf-frobref)))
(SSETF-gensyms expf (append (SETF-gensyms expf)
(SETF-gensyms expf-frobref)))
(SSETF-ret-ok expf (SETF-ret-ok expf-frobref))
expf)
(defun (arraycall SETF-X-ACCESS) (expf array &restl indices)
`(ARRAYCALL ,(SETF-user-slot expf) ,array ,. indices))
(defun (arraycall SETF-X-INVERT) (expf val array &restl indices)
(let ((gensyms (mapcar #'(lambda (() ) (si:gen-local-var () "Index"))
indices)))
(eval-ordered* `(A ,@gensyms V)
`(,array ,@indices ,val)
``((store (arraycall ,',(SETF-user-slot expf)
,A
,,@gensyms)
,V)))))
(defun (arraycall SETF-X) (g)
(let* (( (() type . frobs) g)
(struct (setf-struct #,(get 'ARRAYCALL 'SETF-X-ACCESS)
#,(get 'ARRAYCALL 'SETF-X-INVERT)
'T
frobs)))
(SSETF-user-slot struct type)
struct))
(defsetf GET ((() sym tag) value) T
(eval-ordered* '(X A V)
`(,sym ,tag ,value)
'`((PUTPROP ,X ,V ,A))))
(defsetf PLIST ((() sym) value) T
`(SETPLIST ,sym ,value))
(defsetf SYMEVAL ((() sym) value) T
`(SET ,sym ,value))
(defsetf ARG ((() argument) value) T
`(SETARG ,argument ,value))
(defsetf ARGS ((() argument) value) ()
`(ARGS ,argument ,value))
(defsetf SFA-GET ((() sfa loc) value) T
`(SFA-STORE ,sfa ,loc ,value))
(defsetf FIXNUM-IDENTITY ((() x) value) T
`(FIXNUM-IDENTITY (SETF ,x (FIXNUM-IDENTITY ,value))))
(putprop 'FLONUM-IDENTITY (get 'FIXNUM-IDENTITY 'SETF-X) 'SETF-X)
(defsetf LDB ((() byte word) value) ()
(si:ldb-dpb-stfx word byte () value '(DPB . T)))
(defsetf LOAD-BYTE ((() word position size) value) ()
(si:ldb-dpb-stfx word position size value '(DEPOSIT-BYTE . () )))
(defun SI:LDB-DPB-STFX (word position size value foo)
(let ((dpber (car foo)) ;like *DPB or DEPOSIT-BYTE or ...
(ppssp (cdr foo)) ;non-null iff LDB/DPB rather than LOAD-BYTE/...
(byte position) ;in the LDB case (as opposed to LOAD-BYTE)
(expf (+internal-setf-x-1 word))
side-effects valq valb byteq byteb)
(SETF-simplep-scan expf () )
(cond ((null ppssp) () )
((or (SETF-side-effects expf)
(|side-effectsp/|| value)
(|side-effectsp/|| byte))
(cond ((|constant-p/|| value))
('T (si:gen-local-var valq)
(setq valq (list valq) valb (list value)
value (car valq) side-effects 'T)))
(cond ((|constant-p/|| byte))
('T (si:gen-local-var byteq)
(setq byteq (list byteq) byteb (list byte)
byte (car byteq) side-effects 'T)))))
(let* ((access (setf-access-form expf))
(invert (setf-invert-form
expf
(if ppssp
`(,DPBer ,value ,byte ,access)
`(,DPBer ,access ,position ,size ,value)))))
(cond ((or side-effects (not (null (SETF-gensyms expf))))
`((LAMBDA (,.byteq ,@(SETF-gensyms expf) ,.valq)
,invert)
,.byteb ,@(SETF-genvals expf) ,.valb))
('T invert)))))

566
src/nilcom/setf.294 Normal file
View File

@@ -0,0 +1,566 @@
;;; SETF -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; *************************************************************************
;;; ***** NIL ******** SETF, PUSH, and POP Expanders ***********************
;;; *************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology *************
;;; *************************************************************************
(herald SETF /294)
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((LISP) SUBLOAD)))
(subload SHARPCONDITIONALS)
)
#+(local MacLISP)
(eval-when (compile)
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(SETF +INTERNAL-SETF-X +INTERNAL-SETF-X-1 SETF-SIMPLEP-SCAN
+INTERNAL-CARCDR-SETF +INTERNAL-PUSH-X +INTERNAL-POP-X
DEFUPDATE PUSH POP))
)
#+(or NIL LISPM)
(progn
(globalize "+INTERNAL-SETF-X")
(globalize "+INTERNAL-POP-X")
(globalize "+INTERNAL-SETF-X-1")
(globalize "+INTERNAL-PUSH-X")
(globalize "+INTERNAL-CARCDR-SETF")
(globalize "SETF-SIMPLEP-SCAN")
(globalize "SETF-STRUCT")
(globalize "SETF")
(globalize "DEFUPDATE")
(globalize "STATIC-AREAP")
(globalize "WRITEABLEP")
)
;;; Current contents:
;;; Functions: +INTERNAL-SETF-X, +INTERNAL-SETF-X-1, +INTERNAL-CARCDR-SETF
;;; +INTERNAL-PUSH-X, +INTERNAL-POP-X, DEFUPDATE
;;; and defsetfs for various functions
#-NIL
(eval-when (eval compile)
(subload MACAID)
;; Following will also load VECTOR and DEFVST at eval-compile times
(subload EXTMAC)
(subload EXTEND)
(subload DEFSETF)
(subload EVONCE)
)
;;; ejs: 2018-09-29: commented out since it breaks compilation of this file
;;; (at least declaring eval-ordered* an lexpr does). However, neither
;;; eval-ordered* nor setf-struct are lexprs.
;;;
;#M (eval-when (eval load compile)
; (and (status feature COMPLR)
; (*lexpr EVAL-ORDERED* SETF-STRUCT))
; )
;;Well, when can we take this out? -- JonL, 12/23/80
#N (progn 'compile
(defmacro STATIC-AREAP (&rest l) '() )
(defmacro STATIC-COPY (x) x)
)
#-NIL (progn 'compile
(defmacro STATIC-AREAP (x)
#+PDP10 `(PUREP ,x)
#-PDP10 '() )
(defmacro STATIC-COPY (x)
#+PDP10 `(PURCOPY ,x)
#-PDP10 '() )
)
#+(and MacLISP PDP10) (progn 'compile
(def-or-autoloadable PUREP PUREP)
(def-or-autoloadable WRITEABLEP PUREP)
(def-or-autoloadable LEXPR-FUNCALL LEXPRF)
(def-or-autoloadable EVAL-ORDERED* EVONCE)
(def-or-autoloadable GENTEMP MACAID)
)
;;;; Comments
;; There are problems with doing PUSH and POP regarding multiple evaluations
;; of the computation yielding the stack. Simply expanding into SETF
;; results in unobvious order-of-evaluation and multiple evaluation, and
;; the wrong return result.
;; To deal with this, we interrupt the SETF expansion midway, after all
;; the pieces have been picked apart. The setf expanders for the various
;; functions provide us with a structure containing the computations required,
;; the value to be stored, and continuation functions to apply to the
;; computations to get the forms to store and retrieve the value. This lets
;; us substitute gensyms for computations that we decide should not be repeated
;; and lambda-bind the gensyms to the computations.
;; The components of the setf-struct are as follows
;; * SETF-compute A list (who's length we'll call "n")
;; of forms to be EVAL'ed in the
;; computation prior to storing the
;; value.
;; SETF-i-compute A copy of the initial value of
;; SETF-compute
;; SETF-side-effects A flag, non-null if SETF-SIMPLEP-SCAN
;; encountered any expressions which may
;; have contained side effects.
;; Initially ().
;; * SETF-access A function of n arguments, to be APPLYd
;; to the applied to the computations
;; to give a form to access the
;; specified slot of the structure
;; given the computations with whatever
;; gensym substitutions performed.
;; * SETF-invert A function of n+1 arguments, to be
;; applied to SETF-allcomps
;; * SETF-ret-ok A flag, non-null implies form returned
;; by SETF-invert will be the value of
;; the SETF-value-expr
;; SETF-genvals A list of values for which gensym
;; been substituted for in SETF-compute.
;; SETF-gensyms A list of gensyms, one-to-one with
;; values in SETF-genvals
;; SETF-user-slot A slot available for communication
;; between SETF-X expanders and their
;; continuations (INVERT and ACCESS)
;; These objects are returned by +INTERNAL-SETF-X-1. They are updated by
;; SETF-SIMPLEP-SCAN to build the SETF-genvals and SETF-gensyms slots, from
;; which a lambda form can be wrapped around the accessing and setting.
;; The user of the structure is responsible for remembering the value to
;; be stored, and possibly substituting a gensym for it in the lambda form.
;; The slots marked above with a "*" are supplied by calling the SETF-X
;; property on the X part of (SETF X Y). (the case of X being a symbol
;; is special-cased, and the CAR/CDR cases are handled specially if no
;; SETF property is found.)
;; (SETF-STRUCT access invert ret-ok compute)
;; creates one of these SETF structures. The value component is
;; Note: The variable EFFS herein is not special. It is, however, equivalent
;; in function to the compiler's (NCOMPLR and LCP) variable EFFS. If non-(),
;; the form is being expanded "for effect", i.e. the return value is going to b
;; ignored, so don't bother taking pains to preserve it. It is supplied as ()
;; in the interpreter, and currently in the compiler as well.
;; +INTERNAL-PUSH-X and +INTERNAL-POP-X are called by the interpreter and
;; compiler to expand complex PUSH and POPs. The first argument is the
;; CDR of the PUSH or POP form (viewed as a macro, or the entire argument
;; to the PUSH or POP FSUBR in the interpreter). The second is the
;; EFFS argument as above.
;; (DEFMACRO PUSH (&REST PUSH-ARGS) `(+INTERNAL-PUSH-X ,PUSH-ARGS () ))
;; (DEFMACRO POP (&REST POP-ARGS) `(+INTERNAL-POP-X ,POP-ARGS () ))
;;;; +INTERNAL-PUSH-X and +INTERNAL-POP-X
(defmacro DEFUPDATE (name conser)
`(DEFMACRO ,name (&WHOLE FORM)
(+INTERNAL-PUSH-X (CDR FORM)
() ;Losing compiler doesn't hack EFFS
;at macro-expansion time.
',conser)))
;; example: (defupdate PUSH CONS)
;; (defupdate accumulate PLUS)
;; (defmacro increment (x) `(accumulate 1 ,x))
(defun +INTERNAL-PUSH-X ((val stack) effs &optional (push-cons 'CONS)
&aux valval valsym temp incrementation)
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () )))
(cond ((and (not (|constant-p/|| val))
(not (null (SETF-gensyms expf-stack))))
(setq valval (ncons val)
valsym (ncons (si:gen-local-var val)))))
(setq incrementation `(,push-cons ,val ,(setf-access-form expf-stack)))
(cond ((or effs (SETF-ret-ok expf-stack))
(setq temp (setf-invert-form expf-stack incrementation)))
('T (si:gen-local-var temp)
(setq temp
`((LAMBDA (,temp)
,(setf-invert-form expf-stack temp)
,temp)
,incrementation))))
(cond ((null (SETF-gensyms expf-stack)) temp)
('T `((LAMBDA (,@valsym ,.(SETF-gensyms expf-stack))
,temp)
,.valval ,.(SETF-genvals expf-stack))))))
;; POP must be careful of side-effect interactions between first and second arg
(defun +INTERNAL-POP-X (foo effs &optional (pop-car 'CAR) (pop-cdr 'CDR)
&aux (stack (car foo)) (into (cdr foo)))
(let ((expf-stack (setf-simplep-scan (+internal-setf-x-1 stack) () ))
(expf-into (and (not (null into)) (+internal-setf-x-1 (car into))))
stack-access-form temp tsym )
(if into (setf-simplep-scan expf-into (SETF-side-effects expf-stack) ))
(cond ((or (not (null (SETF-gensyms expf-stack)))
(and into (SETF-side-effects expf-into)))
(si:gen-local-var tsym)
(setq temp `((CAR ,tsym)))
(if (and (not effs) ;Maybe save ret value
(not (SETF-ret-ok expf-into)))
(setq temp `((SETQ ,tsym ,@temp))))
(cond (into
(if (and (SETF-side-effects expf-into)
(not (SETF-side-effects expf-stack)))
(setf-simplep-scan expf-stack 'T))
(setq temp
(ncons (setf-invert-form expf-into (car temp))))))
(if (and (not effs)
(not (SETF-ret-ok expf-into))) ;Maybe need ret value
(setq temp `(,@temp ,tsym)))
`((LAMBDA (,.(SETF-gensyms expf-stack)
,.(and into (SETF-gensyms expf-into)))
((LAMBDA (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
,@temp)
,(setf-access-form expf-stack)))
,.(SETF-genvals expf-stack)
,.(and into (SETF-genvals expf-into))))
((+internal-dup-p
(setq stack-access-form (setf-access-form expf-stack)))
(setq temp `(,pop-car ,stack-access-form))
(cond ((not (null into)) ;Better code with SETQ inside PROG2
(setq temp
(+internal-setf-x `(,(car into) ,temp) effs))))
`(PROG2 ()
,temp
,(setf-invert-form expf-stack `(,pop-cdr ,stack-access-form))))
('T (si:gen-local-var tsym)
(setq temp `((LAMBDA (,tsym)
,(setf-invert-form expf-stack `(,pop-cdr ,tsym))
(,pop-car ,tsym))
,stack-access-form))
(if into
(+internal-setf-x `(,(car into) ,temp) effs)
temp)))))
;;;; SETF macro, +INTERNAL-SETF-X, and SETF-SIMPLEP-SCAN
(defmacro SETF (&rest w) (+internal-setf-x w () ))
(defun +INTERNAL-SETF-X (w effs)
(do ((l w (cddr l))
(form) (val) (expf) (val-gensym) (ret-form))
((null l)
(cond ((null (cdr ret-form)) (car ret-form))
('T `(PROGN ,. (nreverse ret-form)))))
;One step in expanding "(SETF ... form val ... )"
(desetq (form val) l)
(if (null (cdr l))
(setq val (cerror T () ':WRONG-NUMBER-OF-ARGUMENTS
"SETF called with an odd number of arguments. ~@
Extra reference = ~3G~S.~@
Supply a form to evaluate, store and return."
'SETF (length w) w form)))
(setq expf (+INTERNAL-SETF-X-1 form))
(cond ((or (and (null (cddr l)) ;If at end of SETF
(not effs) ;If values matter at all
(not (SETF-ret-ok expf)) ;If it wrong val at end
(not (+internal-dup-p val))) ;And we can't duplicate
(not (equal (SETF-compute expf) ;If already simplified
(SETF-i-compute expf))))
(if (equal (SETF-compute expf)
(SETF-i-compute expf))
(setf-simplep-scan expf () ))
(si:gen-local-var val-gensym)
(push `((lambda (,@(SETF-gensyms expf) ,val-gensym)
,(setf-invert-form expf val-gensym)
,val-gensym)
,@(SETF-genvals expf) ,val)
ret-form))
('T (setq ret-form (cons (setf-invert-form expf val)
ret-form))
(cond ((and (not effs)
(not (cddr l))
(not (SETF-ret-ok expf)))
(setq ret-form (cons val ret-form))))))))
;; Call SETF-SIMPLEP-SCAN on a SETF-STRUCT, and a second arg saying whether
;; or not side effects have been detected.
;; NO-OP if SETF-SIMPLEP-SCAN already called on it.
(defun SETF-SIMPLEP-SCAN (expf known-side-effects?)
(if (null (SETF-gensyms expf))
(do ((rest (SETF-compute expf) (cdr rest))
(clist) (slist) (sitem)
(original) (expansion))
((null rest)
(SSETF-genvals expf (nreverse clist))
(SSETF-gensyms expf (nreverse slist)))
(setq expansion (macroexpand (setq original (car rest))))
;; Why isn't the following RPLACA conditionalized by
;; (cond ((not (static-areap original)))
;; ((writeablep original)
;; ;; Writeable, but 'static', so someday may be purified.
;; (setq expansion (static-copy expansion))
;; 'T))
(rplaca rest expansion)
(cond ((or (|constant-p/|| expansion) ;Always safe!
(and (null known-side-effects?)
(+internal-dup-p expansion)))
;; Nothing to be done in these cases
() )
((and (null known-side-effects?) (|side-effectsp/|| expansion))
;;All is in, so reset and carefully do it again!
(SSETF-compute expf (append (SETF-I-compute expf) () ))
(SSETF-side-effects expf 'T)
(return (setf-simplep-scan expf 'T)))
('T (si:gen-local-var sitem)
(push expansion clist)
(push sitem slist)
(rplaca rest sitem)))))
expf)
;;;; +INTERNAL-SETF-X-1 and +INTERNAL-CARCDR-SETF
;; +INTERNAL-SETF-X-1 takes an access expression and returns a SETF-STRUCT
;; which contains the various info documented at the head of this file.
;; The way the expansion happens is a loop of the following:
;; a) If it's a symbol, special case
;; b) If the CAR is a symbol, and has a SETF-X property, FUNCALL it on the
;; access and value expressions (unless that property is 'AUTOLOAD',
;; meaning that autoloading should be tried if possible, or if it is
;; 'SETF-X' meaning autoloading has been tried and lost).
;; c) If it's a macro, MACROEXPAND-1 it and return
(defun +INTERNAL-SETF-X-1 (expr)
(prog (temp oper)
A (cond ((atom expr)
(cond ((symbolp expr)
(return (SETF-STRUCT `(LAMBDA (()) ',expr)
`(lambda (() y) `(setq ,',expr ,y))
'T
() )))))
((not (symbolp (setq oper (car expr)))) () )
((and (setq temp (get oper 'SETF-X))
(not (memq temp '(AUTOLOAD SETF-X))))
(return (funcall temp expr)))
('T (cond ((and (cond ((null temp)
;;This excludes carcdrs ??
(not (fboundp oper)))
((eq temp 'AUTOLOAD))) ;Help for LDB etc
(setq temp (get oper 'AUTOLOAD)))
(funcall autoload `(,oper . ,temp))
(cond ((setq temp (get oper 'SETF-X))
(return (funcall temp expr)))
('T (putprop oper 'SETF-X 'SETF-X))))
((setq temp (macroexpand-1* expr))
;allow macro-redefinition, even for carcdr functions
(return (+INTERNAL-SETF-X-1 (car temp))))
((setq temp (|carcdrp/|| oper))
(return (+INTERNAL-carcdr-setf temp expr))))))
(setq expr (error '|Obscure format - SETF| expr 'WRNG-TYPE-ARG))
(go A)
))
(defun +INTERNAL-CARCDR-SETF (carcdrspec expr)
(let ((rplac (cond ((eq (car carcdrspec) 'A) 'rplaca)
('T 'rplacd)) )
(op (cond ((eq (car carcdrspec) 'A) 'CAR)
('T 'CDR)))
(carcdr (cadr carcdrspec) )
((() pair) expr)
(subform) )
(setq subform (cond ((or (null carcdr) (eq carcdr 'CR)) pair)
('T `(,carcdr ,pair))))
(SETF-STRUCT `(LAMBDA (() X) `(,',op ,x))
`(LAMBDA (() VALUE PAIR) `(,',rplac ,pair ,value))
()
`(,subform))))
(defun setf-invert-form (expf val)
(lexpr-funcall (SETF-invert expf)
expf
val
(SETF-compute expf)))
(defun setf-access-form (expf)
(lexpr-funcall (SETF-access expf)
expf
(SETF-compute expf)))
; SETF-STRUCT is a slight variant on the constructor function
(defun SETF-STRUCT (access invert ret-ok compute &optional function)
(CONS-A-SETF COMPUTE compute
I-COMPUTE (APPEND compute ())
RET-OK ret-ok
ACCESS access
INVERT invert
FUNCTION function))
;;;; DEFSETFs for various system functions
(defsetf CXR ((() index frob) value) ()
`(RPLACX ,index ,frob ,value))
(defsetf NTH ((() index frob) value) ()
`(RPLACA (NTHCDR ,index ,frob) ,value))
(defsetf NTHCDR ((() index frob) value) ()
`(RPLACD (NTHCDR (1- ,index) ,frob) ,value))
;; The PROGN stuff isn't optimal, it will generate LAMBDAs unnecessarily.
;; Hopefully the compiler will eliminate them.
(defprop PROGN T SETF-PROGNP)
(defun (progn SETF-X-ACCESS) (expf &restl steps)
(let (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'SETF-PROGNP))
(setf-access-form expf-frobref)
`(,fun ,@steps ,(setf-access-form expf-frobref)))))
(defun (progn SETF-X-INVERT) (expf val &restl steps)
(let* (( (fun . expf-frobref) (setf-user-slot expf)))
(if (and (null steps) (get fun 'SETF-PROGNP))
(setf-invert-form expf-frobref val)
`(,fun ,@steps ,(setf-invert-form expf-frobref val)))))
(defun (progn SETF-X)
(expr &aux (fun (car expr)) temp frobref steps expf expf-frobref)
(setq temp (reverse (cdr expr))
frobref (car temp)
steps (nreverse (cdr temp))
expf (setf-simplep-scan
(setf-struct #,(get 'PROGN 'SETF-X-ACCESS)
#,(get 'PROGN 'SETF-X-INVERT)
()
steps)
() )
expf-frobref (setf-simplep-scan (+internal-setf-x-1 frobref) () ))
(SSETF-user-slot expf (list* fun expf-frobref))
(SSETF-genvals expf (append (SETF-genvals expf)
(SETF-genvals expf-frobref)))
(SSETF-gensyms expf (append (SETF-gensyms expf)
(SETF-gensyms expf-frobref)))
(SSETF-ret-ok expf (SETF-ret-ok expf-frobref))
expf)
(defun (arraycall SETF-X-ACCESS) (expf array &restl indices)
`(ARRAYCALL ,(SETF-user-slot expf) ,array ,. indices))
(defun (arraycall SETF-X-INVERT) (expf val array &restl indices)
(let ((gensyms (mapcar #'(lambda (() ) (si:gen-local-var () "Index"))
indices)))
(eval-ordered* `(A ,@gensyms V)
`(,array ,@indices ,val)
``((store (arraycall ,',(SETF-user-slot expf)
,A
,,@gensyms)
,V)))))
(defun (arraycall SETF-X) (g)
(let* (( (() type . frobs) g)
(struct (setf-struct #,(get 'ARRAYCALL 'SETF-X-ACCESS)
#,(get 'ARRAYCALL 'SETF-X-INVERT)
'T
frobs)))
(SSETF-user-slot struct type)
struct))
(defsetf GET ((() sym tag) value) T
(eval-ordered* '(X A V)
`(,sym ,tag ,value)
'`((PUTPROP ,X ,V ,A))))
(defsetf PLIST ((() sym) value) T
`(SETPLIST ,sym ,value))
(defsetf SYMEVAL ((() sym) value) T
`(SET ,sym ,value))
(defsetf ARG ((() argument) value) T
`(SETARG ,argument ,value))
(defsetf ARGS ((() argument) value) ()
`(ARGS ,argument ,value))
(defsetf SFA-GET ((() sfa loc) value) T
`(SFA-STORE ,sfa ,loc ,value))
(defsetf FIXNUM-IDENTITY ((() x) value) T
`(FIXNUM-IDENTITY (SETF ,x (FIXNUM-IDENTITY ,value))))
(putprop 'FLONUM-IDENTITY (get 'FIXNUM-IDENTITY 'SETF-X) 'SETF-X)
(defsetf LDB ((() byte word) value) ()
(si:ldb-dpb-stfx word byte () value '(DPB . T)))
(defsetf LOAD-BYTE ((() word position size) value) ()
(si:ldb-dpb-stfx word position size value '(DEPOSIT-BYTE . () )))
(defun SI:LDB-DPB-STFX (word position size value foo)
(let ((dpber (car foo)) ;like *DPB or DEPOSIT-BYTE or ...
(ppssp (cdr foo)) ;non-null iff LDB/DPB rather than LOAD-BYTE/...
(byte position) ;in the LDB case (as opposed to LOAD-BYTE)
(expf (+internal-setf-x-1 word))
side-effects valq valb byteq byteb)
(SETF-simplep-scan expf () )
(cond ((null ppssp) () )
((or (SETF-side-effects expf)
(|side-effectsp/|| value)
(|side-effectsp/|| byte))
(cond ((|constant-p/|| value))
('T (si:gen-local-var valq)
(setq valq (list valq) valb (list value)
value (car valq) side-effects 'T)))
(cond ((|constant-p/|| byte))
('T (si:gen-local-var byteq)
(setq byteq (list byteq) byteb (list byte)
byte (car byteq) side-effects 'T)))))
(let* ((access (setf-access-form expf))
(invert (setf-invert-form
expf
(if ppssp
`(,DPBer ,value ,byte ,access)
`(,DPBer ,access ,position ,size ,value)))))
(cond ((or side-effects (not (null (SETF-gensyms expf))))
`((LAMBDA (,.byteq ,@(SETF-gensyms expf) ,.valq)
,invert)
,.byteb ,@(SETF-genvals expf) ,.valb))
('T invert)))))

367
src/nilcom/subseq.39 Executable file
View File

@@ -0,0 +1,367 @@
;;; SUBSEQ -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; ************************************************************************
;;; *** NIL ******* SUBSEQuencing and coercion functions *******************
;;; ************************************************************************
;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ************
;;; ************************************************************************
;;; SUBSEQ and REPLACE are seen as a specific usage of the "coercion"
;;; functions.
;;; General coercion routines TO-<mumble>, which take in any kind of
;;; sequence, and give out a corresponding sequence of type <mumble>.
;;; Additionally, in this file is TO-CHARACTER, TO-CHARACTER-N, TO-BIT,
;;; and TO-UPCASE .
(herald SUBSEQ /39)
#+(or LISPM (and NIL (not MacLISP)))
(progn 'compile
(globalize "SUBSEQ")
(globalize "REPLACE")
(globalize "TO-LIST")
(globalize "TO-VECTOR")
(globalize "TO-STRING")
(globalize "TO-BITS")
(globalize "TO-CHARACTER")
(globalize "TO-CHARACTER-N")
(globalize "TO-CHARACTER-N?")
(globalize "TO-SYMBOL")
(globalize "TO-BIT")
(globalize "TO-UPCASE")
)
#-NIL
(eval-when (eval compile)
(or (get 'SUBLOAD 'VERSION)
(load '((lisp) subload)))
(subload SHARPCONDITIONALS)
(subload EXTMAC) ;also gets MACAID, ERRCK,
(subload EXTHUK)
(setq-if-unbound *:bits-per-character #Q 8 #-LISPM 7)
)
#-NIL
(eval-when (eval compile load)
(subload EXTEND)
)
#+(local MacLISP)
(declare (own-symbol LENGTH *:FIXNUM-TO-CHARACTER GET-PNAME)
(own-symbol SUBSEQ REPLACE TO-LIST TO-VECTOR TO-STRING TO-BITS))
;;; Here's some particular macro definitions and declaractions,
;;; knowing that the intended target is with the other maclisp
;;; NILCOM software.
#+(local MacLISP)
(declare (*expr LENGTH *:FIXNUM-TO-CHARACTER TO-CHARACTER-N?
GET-PNAME MAKE-BITS STRING-PNGET)
(*LEXPR MAKE-STRING STRING-REPLACE STRING-SUBSEQ STRING-MISMATCHQ
STRING-POSQ STRING-POSQ-N STRING-BPOSQ STRING-BPOSQ-N )
(FIXNUM (+INTERNAL-CHAR-N () FIXNUM))
(NOTYPE (+INTERNAL-RPLACHAR-N () FIXNUM FIXNUM)))
#-NIL
(eval-when (eval compile)
(setq defmacro-for-compiling () defmacro-displace-call () )
(defmacro STRING-LENGTH (x) `(SI:XREF ,x 1))
(defmacro BITS-LENGTH (x) `(SI:XREF ,x 1))
(defmacro VECTOR-LENGTH (&rest w) `(SI:EXTEND-LENGTH ,.w))
(defmacro EXTEND-LENGTH (&rest w) `(SI:EXTEND-LENGTH ,.w))
(defmacro SI:EXTEND-LENGTH (x) `(- (HUNKSIZE ,x) 2))
(defmacro MAKE-VECTOR (n) `(SI:MAKE-EXTEND ,n VECTOR-CLASS))
(defmacro VREF (&rest w) `(SI:XREF ,.w))
(defmacro VSET (&rest w) `(SI:XSET ,.w))
#M (progn 'compile
(defmacro *:CHARACTER-TO-FIXNUM (c) `(MAKNUM (SI:XREF ,c 0)))
(defmacro SI:SYMBOL-CONS (x)
`(PNPUT (STRING-PNGET ,x 7) () ))
(and (status feature COMPLR)
(SPECIAL |+internal-CHARACTER-table/||))
)
#Q (progn 'compile
(defmacro *:CHARACTER-TO-FIXNUM (VAL) `(AR-1 ,val 1))
)
#-(local PDP10) (progn 'compile
(defmacro +INTERNAL-CHAR-N (&rest w) `(CHAR-N ,.w))
(defmacro +INTERNAL-RPLACHAR-N (&rest w) `(RPLACHAR-N ,.w)) )
(setq defmacro-for-compiling 'T defmacro-displace-call 'T )
)
#M (eval-when (eval load compile)
(and (status feature complr)
(*lexpr SUBSEQ REPLACE TO-LIST TO-VECTOR TO-STRING TO-BITS)))
;;;; SUBSEQ, REPLACE, and coercions TO-<mumble>
(defun SUBSEQ (str &OPTIONAL (i 0) (cnt () cntp))
(SI:replacer () str 0 i cnt cntp () ))
(defun REPLACE (v1 v2 &optional (i1 0) (i2 0) (cnt () cntp))
(SI:replacer v1 v2 i1 i2 cnt cntp () ))
(defun TO-LIST (str &OPTIONAL (i 0) (cnt () cntp))
(SI:replacer () str 0 i cnt cntp 'LIST))
(defun TO-VECTOR (str &OPTIONAL (i 0) (cnt () cntp))
(SI:replacer () str 0 i cnt cntp 'VECTOR))
(defun TO-STRING (ob &OPTIONAL (i 0) (cnt () cntp))
(cond
((and (= i 0)
(null cntp)
(typecaseq ob
(STRING 'T)
(SYMBOL (setq ob (get-pname ob)) 'T)
(FIXNUM (setq ob (+internal-rplachar-n (make-string 1) 0 ob))
'T)
(CHARACTER (setq ob (+internal-rplachar-n
(make-string 1)
0
(*:character-to-fixnum ob)))
'T)))
ob)
('T (SI:replacer () ob 0 i cnt cntp 'STRING))))
(defun TO-BITS (ob &OPTIONAL (i 0) (cnt () cntp))
(cond ((and (= i 0)
(null cntp)
(typecaseq ob
(BITS
'T)
((FIXNUM CHARACTER)
(setq ob (rplacbit (make-bits 1) 1 (to-bit ob)))
'T)))
ob)
('T (if (symbolp ob) (setq ob (get-pname ob)))
(SI:replacer () ob 0 i cnt cntp 'BITS))))
;;;; TO-CHARACTER
(defvar SI:COERCION-ERROR-STRING "~1G~S is not coercible to a ~0G~A")
(defbothmacro TO-CHARACTER (c)
`(*:FIXNUM-TO-CHARACTER (TO-CHARACTER-N? ,c () )))
(defbothmacro TO-CHARACTER-N (c) `(TO-CHARACTER-N? ,c () ))
(defun TO-CHARACTER-N? (char no-error?)
#+(and (not NIL) (local PDP10))
(subload STRING)
(prog (nc)
A (setq nc (typecaseq char
(CHARACTER (*:character-to-fixnum char))
(FIXNUM (if (and (>= char 0)
(< char #.(^ 2 *:bits-per-character)))
char))
(STRING (cond ((= (string-length char) 0) 0)
((+internal-char-n char 0))))
(SYMBOL (cond ((= (flatc char) 0) 0) ;More efficient
((getcharn char 1)))) ; than get-pname
(T () )))
(if (or nc no-error?) (return nc))
(setq char (cerror 'T () ':WRONG-TYPE-ARGUMENT
SI:COERCION-ERROR-STRING 'CHARACTER char))
(go A)))
;;;; SI:replacer
(defun SI:replacer (new str i1 i2 cnt cntp coercion?
#N &optional #N (rset 'T))
(let ((cnt1 cnt) (cnt2 cnt)
(l1 0) (l2 0)
(ty1p) (ty2p)
(*RSET #-NIL *RSET
#+NIL rset)
)
(declare (fixnum l1 l2))
(cond
(*RSET
(check-subsequence (str i2 cnt2) () 'SI:replacer 'T cntp)
(cond (new
(if (and cntp (fixnump cnt1) (not (= cnt1 cnt2)))
(setq cnt1 cnt2))
(check-subsequence (new i1 cnt1) () 'SI:replacer 'T cntp)
(if (or (null cntp) (not (= cnt cnt1)) (not (= cnt cnt2)))
(setq cnt (if (< cnt1 cnt2) cnt1 cnt2))))
('T (setq cnt cnt2)))
(setq cntp 'T)))
(prog () ;; PROG-ification only for use by RETURN
;; First, calculate type and lengths of primary "sequence" argument
;; The types will be encoded as 0 - LIST 1 - VECTOR 2 - EXTEND
;; 3 - STRING 4 - BITS 5 - Other
(typecaseq str
(PAIR (setq ty2p 0 l2 (length str)))
(STRING (setq ty2p 3 l2 (string-length str)) )
(VECTOR (setq ty2p 1 l2 (vector-length str)))
(EXTEND (setq ty2p 2 l2 (extend-length str)))
(BITS (setq ty2p 4 l2 (bits-length str)))
(T (cond ((null str) (setq ty2p 0 l2 0))
((or (null coercion?) (sequencep str))
(+internal-lossage '|Not yet coded| 'SI:REPLACER str))
('T (setq str (list str) ty2p 0 l2 1)))))
(if (and cntp (< l2 cnt)) (setq cnt l2))
;; Calculate type and length of output sequence, if supplied by caller
(cond (new
(typecaseq new
(PAIR (setq ty1p 0 l1 (length new)))
(STRING (setq ty1p 3 l1 (string-length new)) )
(VECTOR (setq ty1p 1 l1 (vector-length new)))
(EXTEND (setq ty1p 2 l1 (extend-length new)))
(BITS (setq ty1p 4 l1 (bits-length new)))
(T (+internal-lossage '|Not yet coded| 'SI:REPLACER new)))
(cond ((null cntp)
(let ((n1 (- l1 i1))
(n2 (- l2 i2)))
(declare (fixnum n1 n2))
(if (< n1 n2)
(setq cnt n1)
(setq cnt n2))
(setq cntp 'T)))
((< l1 cnt) (setq cnt l1))))
('T ;;Create output sequence, if not supplied; default type
;; of output to that of primary "sequence" argument.
(if (null cntp) (setq cnt (- l2 i2)))
(setq ty1p (cond ((null coercion?) ty2p)
((cdr (assq coercion? '((LIST . 0)
(STRING . 3)
(VECTOR . 1)
(EXTEND . 2)
(BITS . 4)))))
(5)))
(if (and (= ty1p ty2p) (= i2 0) (= cnt l2) )
(return str))
(setq new (caseq ty1p
(0 (make-list cnt)) ;LIST
(3 (make-string cnt)) ;STRING
(1 (make-vector cnt)) ;VECTOR
(4 (make-bits cnt)) ;BITS
(2 (si:make-extend cnt (si:extend-class-of str)))
(T (+internal-lossage '|Not yet coded| 'SI:REPLACER () ))))))
;; Use fast code on string-to-string movement; also for bits-to-bits
(cond ((and (= ty1p ty2p)
(or (= ty1p 4) ;BITS
#-Lispm (= ty1p 3) ) ;STRING
)
(return
(let (*RSET)
(caseq ty2p
(3 (string-replace new str i1 i2 cnt))
;(1 (vector-replace new str i1 i2 cnt)) ??
(4 (bits-replace new str i1 i2 cnt)) )))))
(and (= ty2p 0) (setq str (nthcdr i2 str))) ;LIST case
;; Loop to move from one to the other, coercing each item as you go
(let ((fwp 1) (ix1 i1) (ix2 i2) item
(newl (and (= ty1p 0) (nthcdr i1 new))))
(declare (fixnum ix1 ix2 fwp))
;;May have to move in the backwards direction, from the top,
;; if the fields overlap.
(cond ((and (eq new str)
(< ix2 ix1)
(>= (+ ix2 cnt) ix1))
(if (= ty2p 0) ;LIST case
(+internal-lossage "LIST-REPLACEing over self" 'SI:REPLACER () ))
(setq ix1 (+ ix1 cnt -1) ix2 (+ ix2 cnt -1))
(setq fwp -1)))
(do ((n 0 (1+ n)))
((>= n cnt))
(declare (fixnum n))
(setq item (caseq ty2p
(3 (+internal-char-n str ix2))
(1 (vref str ix2))
(2 (si:xref str ix2))
(0 (pop str))
(4 (bit str ix2))
(T (elt str ix2))))
(caseq ty1p
(3 (+internal-rplachar-n new
ix1
(to-character-n item)))
(1 (vset new ix1 item))
(0 (rplaca newl item) (pop newl))
(4 (rplacbit new ix1 (to-bit item)))
(2 (si:xset new ix1 item))
(T (setelt str ix1)))
(setq ix1 (+ ix1 fwp) ix2 (+ ix2 fwp))))
(return new))))
;;;; TO-SYMBOL, TO-BIT, TO-UPCASE
(defun TO-SYMBOL (x)
(cond ((symbolp x) x)
((si:symbol-cons (to-string x)))))
(defun TO-BIT (x)
(prog (y)
B (setq y x)
A (typecaseq y
(FIXNUM (and (>= y 0) (return (boole 1 1 y))))
(STRING (and (= 1 (string-length y))
(setq y (+internal-char-n y 0))
(go A)))
(CHARACTER (setq y (*:character-to-fixnum y))
(and (and (<= #/0 y) (<= y #/1))
(return (boole 1 1 y))))
(SYMBOL (setq y (*:fixnum-to-character (getcharn y 1)))
(go A))
(T () ))
(setq x (cerror 'T () ':WRONG-TYPE-ARGUMENT
SI:COERCION-ERROR-STRING 'BIT y))
(go B)))
(defun TO-UPCASE (x)
(typecaseq x
(FIXNUM (char-upcase x))
(CHARACTER
(*:fixnum-to-character (char-upcase (*:character-to-fixnum x))))
(STRING (string-upcase x))
(SYMBOL (to-symbol (string-upcase (to-string x))))
(PAIR (mapcar #'TO-UPCASE x))
(VECTOR (let ((ln (vector-length x)))
(do ((i (1- ln) (1- i))
(new (make-vector ln)))
((< i 0) new)
(vset new i (to-upcase (vref x i))))))
(T (to-upcase
(cerror 'T () ':WRONG-TYPE-ARGUMENT SI:COERCION-ERROR-STRING
'UPPER-CASE-OBJECT x)))))
#M
(progn 'compile
(and (not (fboundp 'MAKE-LIST))
(putprop 'MAKE-LIST
'(lambda (n) (do ((i n (1- i)) (z () (cons () z)))
((< i 1) z)))
'EXPR))
(mapc '(lambda (x) (or (fboundp (car x))
(get (car x) 'AUTOLOAD)
(putprop (car x) (cadr x) 'AUTOLOAD)))
'((PTR-TYPEP #.(autoload-filename EXTEND))
(MAKE-VECTOR #.(autoload-filename VECTOR))
(MAKE-STRING #.(autoload-filename STRING))
(GET-PNAME #.(autoload-filename STRING))
(STRING-REPLACE #.(autoload-filename STRING))
(+INTERNAL-RPLACHAR-N #.(autoload-filename STRING))
(MAKE-BITS #.(autoload-filename BITS))
(RPLACBIT #.(autoload-filename BITS))
(BITS-REPLACE #.(autoload-filename BITS))))
)

156
src/nilcom/yesnop.44 Executable file
View File

@@ -0,0 +1,156 @@
;;; DEFVSY -*-Mode:Lisp;Package:SI;Lowercase:T-*-
;;; **************************************************************************
;;; *** NIL **** NIL/MACLISP/LISPM Functions for Asking for a Yes/No Answer **
;;; **************************************************************************
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ********
;;; **************************************************************************
(herald YESNOP /44)
#-NIL (include ((lisp) subload lsp))
#-NIL
(eval-when (eval compile)
(subload SHARPCONDITIONALS)
)
#+(or NIL LISPM)
(globalize "Y-OR-N-P" "YES-OR-NO-P")
(defvar QUERY-IO (if (boundp 'STANDARD-OUTPUT) STANDARD-OUTPUT 'T)
"Just so it won't be undefined. Also, announce SPECIAL.")
;;Following subload sets up QUERY-IO as a SFA in MacLISP
#M (subload QUERIO)
#+(local MacLISP)
(eval-when (compile)
(*lexpr STRING-TRIM)
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(Y-OR-N-P YES-OR-NO-P)))
(defvar SI:YESNOP-FORMATTER
#+MacLISP #'?FORMAT
#-MacLISP #'FORMAT
"Function to call for obtaining a correct FORMAT facility.")
(eval-when (eval compile)
(defmacro argv-length (argv)
#M argv
#N `(VECTOR-LENGTH ,argv)
#Q `(LENGTH ,argv)
)
(defmacro argv-ref (a i)
#N `(VREF ,a ,i)
#M `(ARG (1+ ,i))
#Q `(NTH ,i ,a)
)
(defmacro argv-rest (argv i)
#M `(LISTIFY (- ,i ,argv))
#N `(TO-LIST ,argv 2)
#Q `(CDDR ,ARGV)
)
)
(defun Y-OR-N-P #+MacLISP w #-MacLISP (&rest w)
(si:do-a-yesnop 'Y-OR-N-P w))
(defun YES-OR-NO-P #+MacLISP w #-MacLISP (&rest w)
(si:do-a-yesnop 'YES-OR-NO-P w))
#M (defvar SI:YESNOP-NO "No")
#M (defvar SI:YESNOP-YES "Yes")
(defun SI:DO-A-YESNOP (fullp argv)
"Does the prompt and TYI or READLINE for Yes-OR-No-P"
#M (subload-function FORMAT)
(let ((stream QUERY-IO)
(prompt '||)
(n (argv-length argv))
istream ostream
streamp promptp frobs)
;;(&optional (stream QUERY-IO streamp) (prompt '|| promptp) &restl frobs)
(cond ((> n 0)
(setq stream (argv-ref argv 0) streamp 'T)
(cond ((> n 1)
(setq stream (argv-ref argv 1) streamp 'T)
(setq frobs (if (= n 2)
()
(argv-rest argv 2)))))))
(cond ((and streamp ;Allow (y-or-n-p "&Foodp")
(not ; ie., reverse-order args
#M (or (memq stream '(() T))
(sfap stream)
(filep stream))
#N (streamp stream)
#Q (si:io-stream-p stream)
))
(and promptp (setq frobs (cons prompt frobs)))
(setq prompt stream
stream QUERY-IO)))
(setq istream (setq ostream stream))
#M (let (options)
(if (symbolp ostream) (setq ostream TYO istream TYI))
(setq options (car (status FILEMODE ostream)))
(if (not (memq 'TTY options))
(error "Stream doesn't have TTY option" stream))
(if (not (memq 'OUT options))
(setq ostream (status TTYCONS istream)))
(if (not (memq 'IN options))
(setq istream (status TTYCONS ostream))))
(cond ((eq fullp 'Y-OR-N-P)
(do ((char -1))
(() ) ;DO repeatedly
(declare (fixnum char))
;; LISPM does FRESH-LINE, we let it be in FORMAT str
;; (cursorpos 'A stream)
(lexpr-funcall SI:YESNOP-FORMATTER ostream prompt frobs)
(princ '| (Y or N) | ostream)
(setq char (tyi istream))
(cond ((or (= char #/N) (= char #/n))
(princ '| (No)| ostream)
(return () ))
((or (= char #/Y) (= char #/y))
(princ '| (Yes)| ostream)
(return 'T)))))
( (do ((line))
(() ) ;DO repeatedly
(declare (fixnum len))
(lexpr-funcall SI:YESNOP-FORMATTER ostream prompt frobs)
(princ '| (Yes or No) | ostream)
(setq line (readline istream -1))
(if #M (status feature STRING) #N 'T #Q 'T
(progn
#M (cond
((not (stringp SI:YESNOP-NO))
(setq SI:YESNOP-NO (to-string SI:YESNOP-NO)
SI:YESNOP-YES (to-string SI:YESNOP-YES))))
(setq line (string-trim '(#\SPACE #\RUBOUT #\BS #\TAB)
(to-string line)))
(if (string-equal line #+MacLISP SI:YESNOP-NO
#-MacLISP "No")
(return () ))
(if (string-equal line #+MacLISP SI:YESNOP-YES
#-MacLISP "Yes")
(return *:TRUTH)))
#M (progn
(setq line (delete #\SPACE (exploden line)))
(cond ((null line))
((or (= (car line) #/N) (= (car line) #/n))
(pop line)
(and line
(or (= (car line) #/O) (= (car line) #/o))
(null (cdr line))
(return () )))
((or (= (car line) #/Y) (= (car line) #/y))
(pop line)
(and (or (= (car line) #/E) (= (car line) #/e))
(prog2 (pop line) 'T)
(or (= (car line) #/S) (= (car line) #/s))
(null (cdr line))
(return 'T)))))))))))