diff --git a/build/lisp.tcl b/build/lisp.tcl index 1e2fc4d4..60cfd27f 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -48,9 +48,131 @@ respond "*" ":link sys;ts complr,lspdmp;cl.dmp >\r" respond "*" ":link sys;ts cl,sys;ts complr\r" respond "*" ":link info;complr 1,info;lispc >\r" -# inquir -respond "*" ":link lisp;subloa lsp,nilcom;subloa >\r" +# lisp;* fasl that that have autoload properties in interpreter respond "*" ":link sys;.fasl defs,lisp;.fasl defs\r" +respond "*" ":link sys;fasdfs 1,lisp;.fasl defs\r" +respond "*" ":midas lisp;_l;allfil\r" +respond "*" ":midas lisp;_l;bltarr\r" +respond "*" ":midas lisp;_lspsrc;edit\r" +respond "*" ":midas lisp;_l;getmid\r" +respond "*" ":midas lisp;_l;humble\r" +respond "*" ":midas lisp;_lspsrc;sort\r" +expect ":KILL" + +respond "*" ":link lisp;subloa lsp,nilcom;subloa >\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;loop\r" +respond "_" "lisp;_lspsrc;umlmac\r" +respond "_" "lisp;_nilcom;sharpa\r" +respond "_" "lisp;_nilcom;sharpc\r" +respond "_" "lisp;_nilcom;defvst\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;errck\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;backq\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_lspsrc;bits\r" +respond "_" "lisp;_lspsrc;cerror\r" +respond "_" "lisp;_nilcom;defmac\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;defmax\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;defvsx\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;defvsy\r" +respond "_" "lisp;_lspsrc;descri\r" +respond "_" "lisp;_lspsrc;dumpar\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_lspsrc;extmac\r" +respond "_" "lisp;_lspsrc;extbas\r" +respond "_" "lisp;_lspsrc;extsfa\r" +respond "_" "lisp;_nilcom;evonce\r" +respond "_" "lisp;_lspsrc;extend\r" +respond "_" "lisp;_lspsrc;grind\r" +respond "_" "lisp;_lspsrc;grinde\r" +respond "_" "lisp;_lspsrc;lap\r" +respond "_" "lisp;_comlap;ledit\r" +respond "_" "lisp;_nilcom;let\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;macaid\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_lspsrc;mlmac\r" +respond "_" "lisp;_lspsrc;mlsub\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(remprop 'eval-ordered* '*lexpr)" +respond "(T AUTOLOAD ((LISP) EVONCE FASL))" "(maklap)" +respond "_" "lisp;_nilcom;setf\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;sharpm\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;string\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;subseq\r" +respond "_" "lisp;_lspsrc;trace\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_nilcom;yesnop\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "liblsp;_libdoc;lspmac\r" +respond "_" "liblsp;_libdoc;lusets\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "\007" +respond "*" "(load '((lisp) extend))" +respond_load "(maklap)" +respond "_" "lisp;_lspsrc;extstr\r" +respond "_" "\032" +type ":kill\r" + +# inquir respond "*" ":midas inquir;_lsrrtn\r" expect ":KILL" @@ -59,11 +181,9 @@ respond "*" ":link lisp;debug fasl,liblsp;debug fasl\r" respond "*" "complr\013" respond "_" "liblsp;_libdoc;tty\r" respond "_" "inquir;reader\r" -respond "_" "lisp;_lspsrc;umlmac\r" respond "_" "inquir;fake-s\r" respond "_" "rwk;debmac\r" respond "_" "liblsp;_libdoc;lispm\r" -respond "_" "lisp;_nilcom;evonce\r" respond "_" "inquir;inquir\r" respond "_" "\032" type ":kill\r" @@ -141,7 +261,6 @@ respond "_" "\007" respond "*" "(load '((lisp) subloa lsp))" respond "T" "(maklap)" respond "_" "lisp;_lspsrc;funcel\r" -respond "_" "lisp;_lspsrc;bits\r" respond "_" "lisp;_lspsrc;reap\r" respond "_" "lisp;_lspsrc;lexprf\r" respond "_" "lisp;_lspsrc;ldbhlp\r" @@ -149,8 +268,6 @@ respond "_" "\032" type ":kill\r" respond "*" "complr\013" -respond "_" "lisp;_nilcom;sharpa\r" -respond "_" "lisp;_nilcom;sharpc\r" respond "_" "lisp;_nilcom;lsets\r" respond "_" "lisp;_nilcom;drammp\r" respond "(Y or N)" "Y" @@ -161,7 +278,6 @@ respond "*" "complr\013" respond "_" "\007" respond "*" "(load '((lisp) subloa lsp))" respond "T" "(maklap)" -respond "_" "lisp;_nilcom;sharpm\r" respond "_" "lisp;_lspsrc;nilaid\r" respond "_" "\032" type ":kill\r" @@ -242,15 +358,19 @@ respond "*" ":move .temp.;maklap fasl,comlap;mk.fas 80\r" respond "*" ":move .temp.;phas1 fasl,comlap;ph.fas 86\r" respond "*" ":move .temp.;srctrn fasl,comlap;st.fas 20\r" +# and redump compiler +respond "*" "comlap\033\023" +respond "*" ":lisp ccload\r" + # Additional LSPLIB packages respond "*" "complr\013" -respond "_" "liblsp;iota_libdoc;iota\r" -respond "_" "liblsp;time_libdoc;time\r" -respond "_" "liblsp;letfex_libdoc;letfex\r" -respond "_" "liblsp;lusets fasl_libdoc;lusets\r" -respond "_" "liblsp;break fasl_libdoc;break\r" -respond "_" "liblsp;smurf_libdoc;smurf\r" -respond "_" "liblsp;fasdmp fasl_rlb%;fasdmp\r" +respond "_" "liblsp;_libdoc;iota\r" +respond "_" "liblsp;_libdoc;time\r" +respond "_" "liblsp;_libdoc;letfex\r" +respond "_" "liblsp;_libdoc;break\r" +respond "_" "liblsp;_libdoc;smurf\r" +respond "_" "liblsp;_rlb%;fasdmp\r" +respond "_" "liblsp;_libdoc;lispt\r" respond "_" "\032" type ":kill\r" @@ -589,7 +709,6 @@ respond "_" "liblsp;_libdoc;carcdr\r" respond "_" "liblsp;_libdoc;char\r" respond "_" "liblsp;_libdoc;debug*\r" respond "_" "liblsp;_libdoc;defsta\r" -respond "_" "lisp;_libdoc;defvst\r" respond "_" "liblsp;_libdoc;doctor\r" respond "_" "\032" type ":kill\r" @@ -618,11 +737,8 @@ respond "_" "liblsp;_libdoc;grapht\r" respond "_" "liblsp;_libdoc;impdef\r" respond "_" "liblsp;_libdoc;laugh\r" respond "_" "liblsp;_libdoc;lchstr\r" -respond "_" "liblsp;_nilcom;let\r" respond "_" "liblsp;_libdoc;lets\r" respond "_" "liblsp;_libdoc;linere\r" -respond "_" "liblsp;_libdoc;lspmac\r" -respond "_" "liblsp;_libdoc;lispt\r" respond "_" "\032" type ":kill\r" @@ -717,7 +833,6 @@ respond "*" ":delete liblsp;impdef unfasl\r" respond "*" ":delete liblsp;iota unfasl\r" respond "*" ":delete liblsp;laugh unfasl\r" respond "*" ":delete liblsp;lchstr unfasl\r" -respond "*" ":delete liblsp;let unfasl\r" respond "*" ":delete liblsp;letfex unfasl\r" respond "*" ":delete liblsp;lets unfasl\r" respond "*" ":delete liblsp;linere unfasl\r" @@ -789,10 +904,8 @@ type ":kill\r" respond "*" ":midas liblsp;_libdoc;bssq\r" respond "*" ":midas liblsp;_libdoc;aryadr\r" -respond "*" ":midas lisp;_l;humble\r" respond "*" ":midas liblsp;_libdoc;link\r" respond "*" ":midas liblsp;_libdoc;lscall\r" -respond "*" ":link sys;fasdfs 1,lisp;.fasl defs\r" respond "*" ":midas liblsp;_libdoc;cpyhnk\r" respond "*" ":link lisp;defns mid,l;defns >\r" @@ -821,7 +934,6 @@ respond "*" ":midas liblsp;_z;timer\r" respond "*" ":link lisp;vsaid lisp,nilcom;vsaid >\r" respond "*" "complr\013" respond "_" "lisp;_nilcom;vsaid\r" -respond "_" "lisp;_lspsrc;mlsub\r" respond "_" "\032" type ":kill\r" respond "*" ":link liblsp;vsaid fasl,lisp;\r" @@ -830,12 +942,6 @@ respond "*" ":midas liblsp;_gsb;ttyvar\r" respond "Use what filename instead?" "lisp;\r" expect ":KILL" -# MLMAC -respond "*" "complr\013" -respond "_" "lisp;_lspsrc;mlmac\r" -respond "_" "\032" -type ":kill\r" - # DEFSET respond "*" "complr\013" respond "_" "lisp;_nilcom;defset\r" diff --git a/src/comlap/ledit.21 b/src/comlap/ledit.21 new file mode 100755 index 00000000..a2c6a19d --- /dev/null +++ b/src/comlap/ledit.21 @@ -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 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)) diff --git a/src/l/allfil.132 b/src/l/allfil.132 new file mode 100755 index 00000000..51eaa121 --- /dev/null +++ b/src/l/allfil.132 @@ -0,0 +1,1262 @@ + +;;; ************************************************************** +TITLE ***** MACLISP ****** ALLFILES FOR ITS/TOPS10 NEWIO *********** +;;; ************************************************************** +;;; ** (C) COPYRIGHT 1977 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* +;;; ************************************************************** + + +IFNDEF TOPS10, TOPS10==:0 +IFNDEF ITS, ITS==:1-TOPS10 + +.MLLIT==1 +.FASL +IF1,[ +.INSRT SYS:.FASL DEFS +10% .INSRT DSK:SYSTEM;FSDEFS > +10$ .INSRT LISP;DECDFS > +10$ .DECDF +] ;END OF IF1 +TMPC==0 ;TEMPORARY I/O CHANNEL IN NEWIO + +VERPRT ALLFILES + +SUBTTL DOCUMENTATION OF FUNCTIONS + +;;; (ALLFILES X) TAKES THE LIST OF NAMELISTS X AND RETURNS A LIST +;;; OF NAMELISTS IN THE FILE SYSTEM WHICH MATCH ELEMENTS OF X. +;;; THERE IS NO GUARANTEE AS TO THE ORDERING OF THE FILES IN +;;; THE RETURNED LIST. IF A SORTED LIST IS DESIRED, THE SORTCAR +;;; FUNCTION SHOULD BE USED WITH AN APPROPRIATE PREDICATE. +;;; +;;; (DIRECTORY X) IS LIKE (ALLFILES X), BUT INSTEAD OF +;;; NAMELISTS IT RETURNS A LIST OF FILE DESCRIPTORS, WHERE +;;; EACH DESCRIPTOR HAS A NAMELIST IN THE CAR AND A +;;; PROPERTY LIST IN THE CDR. TYPICAL PROPERTIES ARE: +;;; WORDS SIZE OF FILE IN PDP-10 WORDS +;;; CHARACTERS SIZE OF FILE IN ASCII CHARACTERS +;;; BITS SIZE IN BITS +;;; BYTESIZE SIZE OF BYTES FILE WAS WRITTEN IN +;;; BYTES SIZE OF FILE IN BYTES +;;; CREDATE DATE OF CREATION +;;; CRETIME TIME OF CREATION +;;; REFDATE DATE OF MOST RECENT REFERENCE +;;; LINK NAME LINKED TO (ITS) +;;; PACK PACK NUMBER (ITS) +;;; STRUCTURE NAME AND UNIT NUMBER (E.G. DSKB0) (TOPS10) +;;; UNDUMPED T IF FILE NOT YET BACKED UP ON MAGTAPE (ITS) +;;; NOREAP T IF NO REAP BIT IS SET (ITS) +;;; AUTHOR AUTHOR'S PPN (TOPS10) +;;; PROTECTION PROTECTION CODE (TOPS10) +;;; MODE MODE WRITTEN IN (TOPS10) +;;; VERSION VERSION NUMBER FROM RIB (TOPS10) +;;; SPOOL SPOOLING NAME (TOPS10) +;;; +;;; (DIRECTORY X PROPS) IS SIMILAR, BUT INCLUDES ONLY +;;; THE PROPERTIES MENTIONED IN "PROPS" FOR EFFICIENCY. +;;; AS A SPECIAL CASE, OMITTING "LINK" CAUSES LINKS NOT +;;; TO BE INCLUDED AT ALL. +;;; +;;; (MAPALLFILES FN X) IS LIKE (MAPC FN (ALLFILES X)) +;;; BUT DOESN'T HAVE TO CONS UP THE WHOLE LIST AT ONCE. +;;; +;;; (MAPDIRECTORY FN X) AND (MAPDIRECTORY FN X PROPS) +;;; ARE SIMILAR. + +;;; * AS A DEVICE NAME IMPLIES DSK. +;;; * AS A DIRECTORY NAME USES ALL DIRECTORIES FOR DSK, +;;; AND THE DEFAULT DIRECTORY FOR ALL OTHER DEVICES. + +;;; AS A SAFETY FEATURE, THE NAMESTRING "*" IS NOT PERMITTED. + +;;; FLAGS (KEPT IN WORD ON FLP) + +AF.==:1,,525252 +AF.NLO==:400000 ;CONS UP NAMELIST ONLY +AF.WDS==:200000 ;WANT WORDS PROPERTY +AF.CRD==:100000 ;CREATION DATE +AF.CRT==:40000 ;CREATION TIME +AF.RFD==:20000 ;REFERENCE DATE +10% AF.NRP==:10000 ;NOREAP +10$ AF.AUT==:10000 ;AUTHOR PPN +10% AF.DMP==:4000 ;UNDUMPED +10$ AF.PRO==:4000 ;PROTECTION +10% AF.LNK==:2000 ;LINK +10$ AF.MDE==:2000 ;MODE +AF.PAK==:1000 ;PACK NUMBER +AF.CHS==:400 ;CHARACTERS +AF.BIT==:200 ;BITS +AF.BYT==:100 ;BYTES +AF.BYS==:40 ;BYTESIZE +10$ AF.VER==:20 ;VERSION +10$ AF.SPL==:10 ;SPOOLING NAME +AF.ALL==376000 ;"ALL" THE PROPS +10$ AF.ALL==AF.ALL\AF.VER\AF.SPL +AF.MFD==:1 ;1 => MUST USE ALL DIRS IN MFD + +10$[ +;OFFSETS FROM FLP WHILE HACKING A DIRECTORY (TOPS10 ONLY) +DEFINE ORG +-15(FLP)TERMIN ;ORIGION OF FXP WHEN ENTERING ALLFILES +DEFINE HAK +-14(FLP)TERMIN ;CONTAINS ONE OF: HAKUFD, HAKMFD +DEFINE RPT +-13(FLP)TERMIN ;POINTER TO P STACK FOR ROUTINE TO CALL & FOR CHANNEL POINTERS +DEFINE MDP +-12(FXP)TERMIN ;MULTIPLE DEVICE POINTER +DEFINE DVB +-11(FXP)TERMIN ;DEVICE BLOCK +DEFINE FLG +-10(FLP)TERMIN ;FLAGS +DEFINE AOP +-7(FLP)TERMIN ;AOBJN POINTER OVER REQUESTS +DEFINE MFP +-6(FLP)TERMIN ;POINTER TO MFD BLOCK +DEFINE UFP +-5(FLP)TERMIN ;POINTER TO UFD BLOCK +DEFINE ELP +-4(FLP)TERMIN ;POINTER TO EXTENDED LOOKUP BLOCK +DEFINE JSP +-3(FLP)TERMIN ;POINTER TO DSK: SEARCHLIST +DEFINE SSP +-2(FLP)TERMIN ;POINTER TO SYS: SEARCHLIST +DEFINE ASP +-1(FLP)TERMIN ;POINTER TO ALL: SEARCHLIST +DEFINE PTN +-0(FLP)TERMIN ;POINTER TO NAMELISTS REMAINING + +MAXFLP==:15 ;NUMBER OF WORDS TO RESERVE ON FLP +ELL==:35 +] + +SUBTTL FUNCTION ENTRY POINTS + + +.ENTRY ALLFILES SUBR 0002 ;SUBR 1 + MOVSI R,AF.NLO ;WANT NAMELISTS ONLY +ALLFL0: PUSH P,[NIL] ;WILL CONS ENTRIES INTO A LIST + PUSHJ P,DIRGEN ;GENERATE DIRECTORY ENTRIES + ALLFL1 + JRST POPAJ + +ALLFL1: HRRZ B,CRAP(P) ;"CRAP" IS - + CALL 2,.FUNCTION CONS ;DATUM IS IN A + MOVEM A,CRAP(P) + POPJ P, + + +.ENTRY DIRECTORY LSUBR 2003 ;LSUBR (1 . 2) + JSP TT,LWNACK + LA12,,.ATOM DIRECTORY + MOVSI R,AF.ALL ;WANT ALL THE GARBAGE BY DEFAULT + CAMN T,[-2] + JSP F,HAKPROPS ;OF COURSE, USER MAY SPECIFY PROPS + POP P,A + JRST ALLFL0 + + +.ENTRY MAPALLFILES SUBR 0003 ;SUBR 2 + MOVSI R,AF.NLO ;NAMELISTS ONLY +MAPAL0: HRLI A,(JCALL 1,) ;THE OLD "UUO CELL" HACK TO ALLOW CLOBBERAGE + PUSH P,A + MOVEI A,(B) + PUSHJ P,DIRGEN ;DO THE GENERATE BIT + MAPAL1 + SUB P,[1,,1] + SETZ A, + POPJ P, + +MAPAL1: XCT CRAP(P) ;XCT THE UUO TO CALL THE USER FN + + +.ENTRY MAPDIRECTORY LSUBR 3004 ;LSUBR (2 . 3) + JSP TT,LWNACK + LA23,,.ATOM MAPDIRECTORY + MOVSI R,AF.ALL ;ALL THE PROPERTIES BY DEFAULT + CAMN T,[-3] + JSP F,HAKPROPS ;BUT USER MAY SPECIFY THE PROPS + POP P,B + POP P,A + JRST MAPAL0 + + +;;; PROPS PROCESSOR -- SETS FLAGS FROM GIVEN PROPERTY NAMES + +HAKPROPS: + SETZ R, + POP P,A +HAKPR1: JUMPE A,(F) + HLRZ B,(A) + CAIN B,.ATOM WORDS + TLO R,AF.WDS + CAIN B,.ATOM CREDATE + TLO R,AF.CRD + CAIN B,.ATOM CRETIME + TLO R,AF.CRT + CAIN B,.ATOM REFDATE + TLO R,AF.RFD +10%[ CAIN B,.ATOM NOREAP + TLO R,AF.NRP + CAIN B,.ATOM UNDUMPED + TLO R,AF.DMP + CAIN B,.ATOM LINK + TLO R,AF.LNK] + CAIN B,.ATOM PACK + TLO R,AF.PAK + CAIN B,.ATOM CHARACTERS + TLO R,AF.CHS + CAIN B,.ATOM BITS + TLO R,AF.BIT + CAIN B,.ATOM BYTES + TLO R,AF.BYT + CAIN B,.ATOM BYTESIZE + TLO R,AF.BYS +10$[ CAIN B,.ATOM AUTHOR + TLO R,AF.AUT + CAIN B,.ATOM PROTECTION + TLO R,AF.PRO + CAIN B,.ATOM MODE + TLO R,AF.MDE + CAIN B,.ATOM VERSION + TLO R,AF.VER + CAIN B,.ATOM SPOOL + TLO R,AF.SPL] + HRRZ A,(A) + JRST HAKPR1 + +;ITS ONLY CODE FOR DIRECTORY SEARCHING +10%[ SUBTTL GENERATE DIRECTORY ENTRIES (ITS) + +;;; COME HERE WITH FLAGS IN R AND LIST OF NAMELIST PATTERNS IN A + +DIRGEN: MOVEI F,1(FXP) ;FXP WILL ACCUMULATE FOUR-WORD NAME BLOCKS + PUSH FLP,. ;SEE BELOW + PUSH FLP,R ;SAVE FLAGS + PUSH FLP,F ;THIS WILL BECOME AOBJN PTR TO NAME BLOCKS + PUSH P,A ;SAVE LISTS + HRRZ A,.SPECIAL DEFAULTF + PUSHJ P,FIL6BT + SUB FXP,[2,,2] + POP FXP,-2(FLP) + SUB FXP,[1,,1] + HRRZ A,(P) +DIRG1: HLRZ A,(A) +DIRG1Q: CALL 1,.FUNCTION TYPEP + CAIE A,.ATOM SYMBOL + JRST DIRG1R + HLRZ A,@(P) + WTA [NAMESTRING NOT PERMITTED TO ALLFILES - USE A NAMELIST!] + JRST DIRG1Q + +DIRG1R: HLRZ A,@(P) + PUSHJ P,FIL6BT ;CONVERT NAMELIST TO NAME BLOCK + MOVSI T,(SIXBIT \*\) + MOVSI TT,(SIXBIT \DSK\) + CAMN T,-3(FXP) ;* AS A DEVICE => DSK + MOVEM TT,-3(FXP) + CAMN TT,-3(FXP) + JRST DIRG1A + MOVE D,-2(FLP) ;NON-DSK DEVICE, * DIR => DEFAULT SNAME + CAMN T,-2(FXP) + MOVEM D,-2(FXP) + JRST DIRG1B +DIRG1A: MOVSI D,AF.MFD + CAMN T,-2(FXP) ;DSK DEVICE, * DIR => USE ALL DIRS IN MFD + IORM D,-1(FLP) +DIRG1B: MOVSI D,-4 ;BUMP SIZE OF AOBJN PTR + ADDM D,(FLP) + HRRZ A,@(P) + MOVEM A,(P) + JUMPN A,DIRG1 + PUSH P,(P) ;A NIL; CREATE TWO NILS ON STACK + PUSH FLP,(FLP) ;COPY AOBJN PTR +;STATE OF THE WORLD: +; FLP: AOBJN POINTER TO PART OF BLOCK AS YET UNSEARCHED FOR +; AOBJN POINTER TO WHOLE BLOCK OF NAMES ON FXP +; FLAGS WORD +; DEFAULT SNAME +; FXP: +; P: NIL ;FOR DIR ARRAY +; NIL ;FOR MFD ARRAY +; RETURN ADDRESS (POINTS TO ADDRESS OF RECEIVER) +CRAP==:-6 ;RET ADR, TWO NILS, PUSHJ TO MFDHAK, + ; PUSHJ TO DIRHAK, PUSHJ TO RECEIVER + MOVE R,-2(FLP) + TLNE R,AF.MFD ;DO THE MFD THING IF NECESSARY + PUSHJ P,MFDHAK + PUSH P,. ;NULL SLOT (FAKES THE PUSHJ TO MFDHAK) + MOVE D,(FLP) ;NOW SCAN OVER ALL NAME BLOCKS +DIRG2: SKIPE (D) + JRST DIRG2F ;JUMP IF NOT FLUSHED YET +DIRG2A: MOVE D,[4,,4] + ADDB D,(FLP) + JUMPL D,DIRG2 + HLRE TT,-1(FLP) ;RESTORE FXP + MOVNS TT + HRLI TT,(TT) + SUB FXP,TT + SUB FLP,[4,,4] ;RESTORE FLP + SKIPN T,-2(P) ;RELEASE THE ARRAYS + JRST DIRG2Z + PUSH P,[DIRG2Z] + PUSH P,T + MOVNI T,1 + JCALL 16,.FUNCTION *REARRAY +DIRG2Z: SKIPN T,-1(P) + JRST DIRG2Y + PUSH P,[DIRG2Y] + PUSH P,T + MOVNI T,1 + JCALL 16,.FUNCTION *REARRAY +DIRG2Y: SUB P,[3,,3] ;RESTORE P + POP P,T + JRST 1(T) ;SKIP RETURN + +DIRG2F: MOVEM D,(FLP) ;FOUND A NAME BLOCK + MOVE TT,1(D) + MOVE T,(D) + PUSHJ P,DIRHAK ;HACK A DIRECTORY FOR THAT ENTRY'S SAKE + MOVE D,(FLP) ; (MAY SATISFY OTHER ENTRIES ALSO, + JRST DIRG2A ; AND THEY WILL BE FLUSHED) + +;;; DISPATCH TO SOME DIRECTORY GROVELER + +DIRHAK: JRST DSKDIR .SEE DSKD1 ;EXCLUDE LOSING DEVICES BY LOOKING INSIDE +; CAMN T,[SIXBIT \DSK\] ;DSK => DSK DIRECTORY +; JRST DSKDIR +; CAME T,[SIXBIT \AI\] ;MANY OTHER DEVICES ARE DSK-LIKE +; CAMN T,[SIXBIT \ML\] ;Indeed! Like ARC's ... --SMM +; JRST DSKDIR +; CAME T,[SIXBIT \MC\] +; CAMN T,[SIXBIT \DM\] +; JRST DSKDIR +; CAMN T,[SIXBIT \TTY\] +; JRST TTYDIR +; POPJ P, ;DO NOTHING FOR UNKNOWN DEVICE + +SUBTTL GROVEL OVER DSK MFD + +;;; DO DSK DIRECTORY THING FOR EVERY DIRECTORY IN MFD + +MFDHAK: SKIPN A,-2(P) + PUSHJ P,GETMFD ;GET MFD ARRAY IF NECESSARY + MOVEM A,-2(P) + MOVEI TT,MDNAMP ;OFFSET OF START OF NAME AREA + MOVE D,@TTSAR(A) + HRLI D,-2000(D) + MOVEI TT,MDCHK ;USURP MDCHK TO HOLD AOBJN PTR +MFDH1: MOVEM D,@TTSAR(A) + MOVEI TT,MNUNAM(D) ;GET A DIRECTORY NAME FROM MFD + MOVSI T,(SIXBIT \DSK\) ;THE DEVICE NAME IS "DSK" + SKIPE TT,@TTSAR(A) + PUSHJ P,DSKDIR ;HACK THAT DIRECTORY (IF NOT ZERO) + MOVE A,-2(P) + MOVEI TT,MDCHK + MOVE D,@TTSAR(A) + ADD D,[LMNBLK,,LMNBLK] ;LOOP OVER ALL MFD ENTRIES + JUMPL D,MFDH1 + POPJ P, + +;;; ROUTINE TO MAKE A FIXNUM ARRAY WITH THE DSK MFD IN IT + +GETMFD: PUSH P,[GTMFD1] ;THE MFD IS 2000 WORDS LONG + PUSH P,[NIL] + PUSH P,[.ATOM FIXNUM ] + PUSH P,[.ATOM #2000 ] + MOVNI T,3 + JCALL 16,.FUNCTION *ARRAY +GTMFD1: HLLOS NOQUIT ;LOCK OUT INTERRUPTS AND QUITS + .OPEN TMPC,[SIXBIT \ &DSKM.F.D.(FILE)\] + .VALUE + HRRZ TT,TTSAR(A) + HRLI TT,-2000 + .IOT TMPC,TT ;GOBBLE DOWN MFD + .CLOSE TMPC, + HRRZS NOQUIT + JRST CHECKI ;UNLOCK INTERRUPTS + +SUBTTL GROVEL OVER DSK DIRECTORY + + +DSKDIR: PUSH FXP,T ;DEVICE NAME (DSK, AI, ML, MC, DM) + PUSH FXP,TT ;DIRECTORY NAME + SKIPE A,-2(P) ;MAY NEED TO CREATE ARRAY TO HOLD DIR + JRST DSKD1 ;NOPE - ONE ALREADY CREATED + PUSH P,[DSKD1] ;OTHERWISE CREATE ONE + PUSH P,[NIL] ;A DSK DIRECTORY IS 2000 WORDS LONG + PUSH P,[.ATOM FIXNUM ] + PUSH P,[.ATOM #2000 ] + MOVNI T,3 + JCALL 16,.FUNCTION *ARRAY +DSKD1: MOVEM A,-2(P) + HLLOS NOQUIT ;LOCK OUT INTERRUPTS AND QUITS + .CALL DSKD9 + JRST DSKD8 ;DIR MAY NOT EXIST -- BUT THERE ARE OTHER POSSIBILITIES + HRRZ TT,TTSAR(A) + HRLI TT,-2001 + .IOT TMPC,TT ;GOBBLE DOWN DIR + .CLOSE TMPC, + HLLZS NOQUIT + PUSHJ P,CHECKI ;UNLOCK INTERRUPTS + AOBJN TT,DSKD8A ;Directory too short--First of a series of checks + TLNE TT,-1 ;Too long? ;Even on KA, this wins because lisp doesn't + JRST DSKD8A ; use last page (remember aobjn difference?) + MOVEI TT,UDESCP ;More checks for "In DSK dir format?" + MOVE D,@TTSAR(A) + CAIL D,6*<2000-11> ;Maximum possible value for udescp + JRST DSKD8A +; MOVEI TT,UDNAME ;Check that user name agrees (will screw translations-- +; MOVE D,@TTSAR(A) ; is that a bug or a feature?--i think a bug) +; CAME D,0(FXP) ;The other checks should be sufficient to exclude +; JRST DSKD8A ; the most obvious cases: TTY, COR... and include + MOVEI TT,UDNAMP ; DSK:, AI:..., DIR:, ARC: (including funny names) + MOVE D,@TTSAR(A) + CAILE D,2000 ;Maximum value for udnamp + JRST DSKD8A + HRLI D,-2000(D) + MOVEI TT,UDNAME +DSKD2: JUMPL D,DSKD2A + POP FXP,TT ;ALL DONE -- FLUSH SATISFIED NAME BLOCKS + POP FXP,T + JRST FMARK + +DSKD2A: MOVEM D,@TTSAR(A) ;USURP UDNAME FOR AOBJN PTR + MOVEI TT,UNRNDM(D) + MOVE T,@TTSAR(A) + TLNE T,DELBTS ;IGNORE DELETED FILES + JRST DSKD7 + TLNN T,UNLINK + JRST DSKD3 + MOVE F,-2(FLP) ;IGNORE LINKS IF NOT + TLNE F,AF.NLO ; SPECIFICALLY ASKED FOR + JRST DSKD3 + TLNN F,AF.LNK + JRST DSKD7 +DSKD3: MOVEI TT,UNFN2(D) ;ELSE GET FILE NAMES + MOVE R,@TTSAR(A) + MOVEI TT,UNFN1(D) + MOVE D,@TTSAR(A) + MOVE T,-1(FXP) ;GET DEVICE AND DIR NAMES + MOVE TT,(FXP) + PUSHJ P,FMATCH ;TRY TO MATCH A NAME BLOCK + JRST DSKD7 ;LOSE LOSE + MOVE F,-2(FLP) ;IF WIN, NAMELIST IS IN A + TLNE F,AF.NLO + JRST DSKD6 ;WANT JUST THE NAMELIST + MOVEI TT,UDNAME ;WANT INFINITE CRAP. + MOVE AR2A,-2(P) ; SET UP DIR ARRAY IN AR2A, + MOVE D,@TTSAR(AR2A) ; DIR INDEX IN D, + SETZ AR1, ; ACCUMULATING PLIST IN AR1. + PUSH P,A ;HACK ALL THE POSSIBLE PROPERTIES + TLNE F,AF.DMP + PUSHJ P,PRDMP ;INVERSE OF DUMPED BIT + TLNE F,AF.NRP + PUSHJ P,PRNRP ;NOREAP BIT + TLNE F,AF.PAK + PUSHJ P,PRPAK + TLNE F,AF.RFD + PUSHJ P,PRRFD ;REFERENCE DATE + TLNE F,AF.CRT + PUSHJ P,PRCRT ;CREATION TIME + TLNE F,AF.CRD + PUSHJ P,PRCRD ;CREATION DATE + TLNE F,AF.LNK + PUSHJ P,PRLNK ;LINK + TLNE F,AF.WDS\AF.CHS\AF.BIT\AF.BYT\AF.BYS + PUSHJ P,PRSIZ ;VARIOUS SIZES + POP P,A + MOVEI B,(AR1) + CALL 2,.FUNCTION CONS ;CONS TOGETHER NAMELIST AND PLIST +DSKD6: MOVE T,@CRAP+2(P) ;CALL THE RECEIVER WITH THE GOODIE + PUSHJ P,(T) +DSKD7: MOVE A,-2(P) ;CYCLE OVER ALL DSK DIRECTORY ENTRIES + MOVEI TT,UDNAME + MOVE D,@TTSAR(A) + ADD D,[LUNBLK,,LUNBLK] + JRST DSKD2 + +DSKD8A: ;PERHAPS EVENTUALLY USE FOR "USER LOSSAGE" ENTRY +DSKD8: HLLZS NOQUIT ;Directory doesn't exist or perhaps can't be gotten + ; should check if error of type 6,7,10 (i.e. recoverable + ; system error) and if not give "user error" + SUB FXP,[2,,2] ;RESTORE THE WORLD AND EXIT, + JRST CHECKI ; UNLOCKING INTERRUPTS + +DSKD9: SETZ + SIXBIT \OPEN\ ;OPEN FILE + 5000,,6 ;IMAGE BLOCK INPUT MODE + 1000,,TMPC ;CHANNEL # + ,,-1(FXP) ;DEVICE NAME + ,,[SIXBIT \.FILE.\] ;FILE NAME 1 + ,,[SIXBIT \(DIR)\] ;FILE NAME 2 + 400000,,0(FXP) ;DIRECTORY NAME + +SUBTTL PROPERTY CONSING ROUTINES + + +PRDMP: MOVEI TT,UNRNDM(D) + MOVE T,@TTSAR(AR2A) + TLNE T,UNDUMP + POPJ P, + MOVEI C,.ATOM UNDUMPED +PRBIT: MOVEI A,.ATOM T + JRST PRCONS + +PRNRP: MOVEI TT,UNRNDM(D) + MOVE T,@TTSAR(AR2A) + TLNN T,UNREAP + POPJ P, + MOVEI C,.ATOM NOREAP + JRST PRBIT + +PRPAK: MOVEI TT,UNRNDM(D) + LDB TT,[UNPKN @TTSAR(AR2A)] + MOVEI C,.ATOM PACK +PFCONS: JSP T,FXCONS +PRCONS: MOVEI B,(AR1) + CALL 2,.FUNCTION CONS + MOVEI B,(C) + CALL 2,.FUNCTION XCONS + MOVEI AR1,(B) + POPJ P, + +PRRFD: MOVEI TT,UNREF(D) + MOVEI C,.ATOM REFDATE + JRST PRCRD1 + +PRCRD: MOVEI TT,UNDATE(D) + MOVEI C,.ATOM CREDATE +PRCRD1: MOVE R,@TTSAR(AR2A) + LDB TT,[UNDAY R] + JSP T,FXCONS + CALL 1,.FUNCTION NCONS + MOVEI B,(A) + LDB TT,[UNMON R] + JSP T,FXCONS + CALL 2,.FUNCTION CONS + MOVEI B,(A) + LDB TT,[UNYRB R] + JSP T,FXCONS + CALL 2,.FUNCTION CONS + JRST PRCONS + +PRCRT: MOVEI TT,UNDATE(D) + MOVEI C,.ATOM CRETIME + LDB T,[UNTIM @TTSAR(AR2A)] + LSH T,-1 ;DSK TIME IN IN HALF-SECONDS + IDIVI T,60. + PUSH FXP,TT + IDIVI T,60. + PUSH FXP,T + EXCH TT,-1(FXP) + JSP T,FXCONS + CALL 1,.FUNCTION NCONS + MOVEI B,(A) + MOVE TT,-1(FXP) + JSP T,FXCONS + CALL 2,.FUNCTION CONS + MOVEI B,(A) + POP FXP,TT + JSP T,FXCONS + CALL 2,.FUNCTION CONS + SUB FXP,[1,,1] + JRST PRCONS + +PRLNK: MOVEI TT,UNRNDM(D) + MOVE T,@TTSAR(AR2A) + TLNN T,UNLINK ;NO LINK PROP IF NOT A LINK + POPJ P, + ANDI T,.BM UNDSCP ;GOBBLE UP DESCRIPTOR POINTER + IDIVI T,UFDBPW ;CONVERT TO BYTE POINTER + MOVEI R,44 + IMULI TT,UFDBYT + SUBI R,(TT) + ROT R,-6 + ADD R,[UFDBYT_6,,] + HRRI R,UDDESC(T) +;R NOW HAS BYTE POINTER INTO DIR FOR LINK DESCRIPTOR + MOVEI A,3 ;WILL GOBBLE DIR AND TWO FILE NAMES + PUSH FXP,-1(FXP) ;DEVICE IS SAME AS WAS GIVEN TO DSKDIR + PUSH FXP,[0] +PRLNK1: MOVEI T,(FXP) ;BYTE POINTER FOR ACCUMLATING NAME + HRLI T,440600 + PUSH FXP,T +PRLNK2: IBP R ;INCREMENT DESCRIPTOR BYTE PTR + MOVEI TT,(R) + HLLZ T,R + ADD T,[@TTSAR(AR2A)] + LDB TT,T ;GOBBLE BYTE FROM ARRAY + CAIE TT,'; ;SEMICOLON TERMINATES NAMES + CAIN TT,0 ;SO DOES A ZERO BYTE + JRST PRLNK4 + CAIE TT,': ;COLON QUOTES CHARACTERSSP; + JRST PRLNK3 + IBP R ;FETCH QUOTED BYTE + MOVEI TT,(R) + HLLZ T,R + ADD T,[@TTSAR(AR2A)] + LDB TT,T +PRLNK3: IDPB TT,(FXP) ;PUT BYTE INTO NAME + LDB T,[360600,,(FXP)] + JUMPN T,PRLNK2 ;FILLING NAME WORD ALSO FINISHES +PRLNK4: SETZM (FXP) ;MAY NEED TO GOBBLE + SOJG A,PRLNK1 ; ANOTHER NAME + SUB FXP,[1,,1] + PUSH FLP,D + PUSH P,AR2A + PUSH P,AR1 + PUSHJ P,6BTNML ;NAME A NAMELIST FOR LINK (SAVES F) + POP P,AR1 + POP P,AR2A + POP FLP,D + MOVEI C,.ATOM LINK + JRST PRCONS ;CONS ON LINK PROPERTY + +PRSIZ: MOVEI TT,UNRNDM(D) + MOVE T,@TTSAR(AR2A) + TLNE T,UNLINK ;NO SIZE PROPS IF A LINK + POPJ P, + ANDI T,.BM UNDSCP ;GOBBLE UP DESCRIPTOR POINTER + IDIVI T,UFDBPW ;CONVERT TO BYTE POINTER + MOVEI R,44 + IMULI TT,UFDBYT + SUBI R,(TT) + ROT R,-6 + ADD R,[UFDBYT_6,,] + HRRI R,UDDESC(T) +;R NOW HAS BYTE POINTER FOR FILE BLOCK DESCRIPTOR BYTES +;THE FOLLOWING CODE WAS SWIPED FROM NFLLN1 IN ITS + SETO T, +PRSIZ1: IBP R ;FETCH NEXT BYTE + MOVEI TT,(R) + HLLZ C,R + ADD C,[@TTSAR(AR2A)] ;TTSAR=1, ERGO SAFE TO PUT IN C + LDB TT,C + JUMPE TT,PRSIZ5 ;ZERO BYTE TERMINATES + CAILE TT,UDTKMX + JRST PRSIZ2 + ADDI T,(TT) ;NEXT N BLOCKS + JRST PRSIZ1 + +PRSIZ2: CAIGE TT,UDWPH + AOJA T,PRSIZ1 ;SKIP N, TAKE 1 + CAIN TT,UDWPH + JRST PRSIZ1 ;PLACE-HOLDER OR NULL +REPEAT NXLBYT, IBP R ;LOAD ADDRESS (GOBBLES MORE BYTES), + AOJA T,PRSIZ1 ; TAKE 1 BLOCK + +PRSIZ5: IMULI T,2000 + MOVEI TT,UNRNDM(D) + LDB TT,[UNWRDC @TTSAR(AR2A)] + SKIPN TT ;NUMBER OF WORDS IN + MOVEI TT,2000 ; LAST BLOCK + ADD TT,T + PUSH FXP,TT ;THIS IS THE SIZE IN WORDS + MOVEI C,.ATOM WORDS + TLNE F,AF.WDS + PUSHJ P,PFCONS +;THE FOLLOWING CODE WAS SWIPED FROM QBDCD IN ITS + MOVEI TT,UNREF(D) + LDB T,[UNBYTE @TTSAR(AR2A)] + TRZN T,400 + JRST PRSZ6A + IDIVI T,100 + JRST PRSZ6F + +PRSZ6A: TRZN T,200 + JRST PRSZ6B + IDIVI T,20 + JRST PRSZ6F + +PRSZ6B: SUBI T,44 + JUMPL T,PRSZ6C + IDIVI T,4 + JRST PRSZ6F + +PRSZ6C: MOVNS T + SETZ TT, +;BYTE SIZE IS IN T, NUMBER OF UNUSED BYTES IN TT +PRSZ6F: PUSH FXP,T + PUSH FXP,TT + MOVEI TT,44 + IDIV TT,-1(FXP) + PUSH FXP,TT +;FXP HAS: BYTES PER WORD, NUMBER OF UNUSED BYTES, BYTE SIZE, FILE LENGTH IN WORDS + IMUL TT,-3(FXP) + SUB TT,-1(FXP) ;BYTES IN FILE + MOVE R,TT + IMUL TT,-2(FXP) ;BITS IN FILE + MOVEI C,.ATOM BITS + TLNE F,AF.BIT + PUSHJ P,PFCONS + MOVE TT,R + MOVEI C,.ATOM BYTES + TLNE F,AF.BYT + PUSHJ P,PFCONS + MOVE TT,-2(FXP) ;BYTE SIZE + MOVEI C,.ATOM BYTESIZE + TLNE F,AF.BYS + PUSHJ P,PFCONS + MOVE T,(FXP) + SUB T,-1(FXP) ;NUMBER OF USED BYTES IN LAST WORD + IMUL T,-2(FXP) ;NUMBER OF USED BITS IN LAST WORD + IDIVI T,7 ;NUMBER OF USED CHARACTERS IN LAST WORD + SOS TT,-3(FXP) + IMULI TT,5 ;NUMBER OF USED CHARACTERS IN ALL BUT LAST WORD + ADD TT,T + MOVEI C,.ATOM CHARACTERS + TLNE F,AF.CHS + PUSHJ P,PFCONS + SUB FXP,[4,,4] + POPJ P, + +SUBTTL UTILITY ROUTINES (FILE NAME MATCHER, EXPUNGER, ETC.) + +;;; TAKE FILE NAMES IN T, TT, D, R AND SKIP IFF A MATCH +;;; IS FOUND IN GIVEN LIST OF FILE NAMES. + +FMATCH: MOVE F,-1(FLP) + MOVSI AR2A,(SIXBIT \*\) +FMAT0: SKIPN (F) ;CAN'T MATCH FLUSHED ENTRY + JRST FMAT7 + CAME T,(F) ;MATCH DEVICE NAME + CAMN AR2A,(F) + CAIA + JRST FMAT7 + CAME TT,1(F) ;MATCH SNAME + CAMN AR2A,1(F) + CAIA + JRST FMAT7 + CAME D,2(F) ;MATCH FILE NAME 1 + CAMN AR2A,2(F) + CAIA + JRST FMAT7 + CAME R,3(F) ;MATCH FILE NAME 2 + CAMN AR2A,3(F) + CAIA + JRST FMAT7 + PUSH FXP,T ;IF MATCH, CREATE NAMELIST + PUSH FXP,TT + PUSH FXP,D + PUSH FXP,R + AOS (P) ;SKIP RETURN + JRST 6BTNML + +FMAT7: ADD F,[3,,3] ;CYCLE OVER ALL NAME BLOCKS + AOBJN F,FMAT0 + POPJ P, ;NO SKIP IF LOSE + + +;;; TAKE (DEV,DIR) IN (T,TT) AND FLUSH ALL PATTERNS +;;; WHICH MATCH EXACTLY (THEY CAN'T BE USED AGAIN, SINCE +;;; WE HAVE ALREADY TRAVERSED THAT DEVICE DIRECTORY). +;;; A PATTERN IS FLUSHED BY ZEROING THE DEVICE NAME. +;;; IF TT HAS 0, DIR IS IGNORED. + +FMARK: MOVE F,-1(FLP) +FMARK0: SKIPE TT + CAMN TT,1(F) + CAME T,(F) + CAIA + SETZM (F) + ADD F,[4,,4] + JUMPL F,FMARK0 + POPJ P, + +IF2,[ ;EXPUNGE ALL THE CRETINOUS SYMBOLS +DEFINE DEFSYM X/ +IRPS Z,,[X] +EXPUNGE Z +TERMIN +TERMIN +.INSRT DSK:SYSTEM;FSDEFS > +] ;END OF IF2 +] ;END OF 10% + + +;TOPS10 ONLY DIRECTORY SEARCHING AND PROPERTY CONSING ROUTINES +10$[ SUBTTL GENERATE DIRECTORY ENTRIES (TOPS10) + +;;; COME HERE WITH FLAGS IN R AND LIST OF NAMELIST PATTERNS IN A + +DIRGEN: +REPEAT MAXFLP, PUSH FLP,[0] ;ALLOCATE THE APPROPRIATE NUMBER OF WORDS + MOVEM P,RTP ;SAVE THE CURRENT +REPEAT 3, PUSH P,[0] ;ALSO NEED 3 WORDS ON P + MOVEM R,FLG ;SAVE FLAGS ON FLP + MOVEI F,1(FXP) ;THIS WILL BECOME PONTER TO NAMELISTS + MOVEM F,AOP + MOVEM FXP,ORG ;SAVE FXP SO IT CAN BE RESTORED LATER + PUSH P,A ;SAVE LIST POINTER + HLRZ A,(A) ;GET THE CAR +DIRNL: CALL 1,.FUNCTION TYPEP ;GET TYPE +DIRCHT: CAIE A,.ATOM SYMBOL ;MUST NOT BE A SYMBOL + JRST DIRNSY ;OK IF NOT + HLRZ A,@(P) + WTA [NAMESTRING not permitted to ALLFILES -- Use a NAMELIST!] + JRST DIRCHT + +DIRNSY: HLRZ A,@(P) ;NAMELIST + PUSHJ P,FIL6BT ;CONVERT TO SIXBIT ON FXP STACK + HRLZI T,(SIXBIT/*/) ;WILDCARD CHARACTER + HRLZI TT,(SIXBIT/DSK/) ;DEFAULT DEVICE NAME + CAMN T,-3(FXP) ;WILDCARD DEVICE? + MOVEM TT,-3(FXP) ;YES, REPLACE WITH DSK + MOVE D,-3(FXP) ;GET FINALIZED DEVICE + DEVTYP D, ;GET TYPE BITS + JRST DIRNDU ;NO DEVTYP UUO, WE MUST USE OTHER MEANS + TRNE D,77 ;DEVICE 0 MEANS DISK + JRST DIRNDK ;NOT A DISK, MUST TAKE DRASTIC MEASURES! + PUSH FXP,[0] ;BUILD OPEN BLOCK + PUSH FXP,-4(FXP) ;DEVICE + PUSH FXP,[0] ;NO BUFFERS +;Lock LISP interrupts here as we will use TMPC + OPEN TMPC,-2(FXP) ;GET THE DEVICE + JRST DIROER ;NOT THERE, WHY DID DEVNAM WORK? + MOVEI T,-2(FXP) ;POINTER TO STACK FOR PATH. UUO + HRLI T,3 ;NEED THREE VALUES + MOVEI TT,TMPC ;CHANNEL FOR PATH. + MOVEM TT,-2(FXP) ;STORE IN ARG BLOCK + PATH. T, ;NOW GET DATA ABOUT DEVICE + JRST DIRNPU ;MUST BE NO PATH. UUO, KLUDGE DATA SOME OTHER WAY + RELEAS TMPC, ;WE DON'T NEED THE DEVICE ANYMORE +;Done with TMPC, we can unlock interrupts + MOVEI TT,PT.IPP ;THIS DEVICE HAVE AN IMPLIED PPN (ERSATZ DEVICE)? + TDNN TT,-1(FXP) + JRST DIRNIP ;NOT IMPLIED PPN, GO ON + MOVE TT,(FXP) ;GET THE DEVICE'S PPN + MOVEM TT,-5(FXP) ;REPLACE USER'S VALUE + HRLZI TT,(SIXBIT/DSK/) ;SUBSTITUTE LEFT HALF OF DEVICE WITH 'DSK' + HLLM TT,-2(FXP) +DIRNIP: LDB TT,[XXX] ;GET SEARCHLIST BYTE + MOVE D,-2(FXP) ;GET DEVICE FROM PATH. RETURN + TRNE D,-1 ;NOT EXPLICIT STRUCTURE? + CAIN TT,2 ;OR JOB SEARCHLIST? + HRLZI D,(SIXBIT/DSK/) ;YES, USE DSK + CAIN TT,3 ;SYS: SEARCHLIST? + HRLZI D,(SIXBIT/SYS/) + CAIN TT,1 ;ALL STRUCTURES? + HRLZI D,(SIXBIT/ALL/) + SUB FXP,[3,,3] ;WE NO LONGER NEED PATH./OPEN BLOCK + MOVEM D,-3(FXP) ;STORE NEW DEVICE NAME + SETZI TT, ;START WITH NO FLAGS + CAMN D,[SIXBIT/SYS/] ;SYSTEM DEVICE? + MOVEI TT,DF.SYS ;YES, FLAG AS SUCH + CAMN D,[SIXBIT/ALL/] ;THIS IS ALSO SPECIAL + MOVEI TT,DF.ALL + CAMN D,[SIXBIT/DSK/] ;LAST CHECK + MOVEI TT,DF.DSK + HRRM TT,(FXP) ;STORE FLAGS NEXT TO THE EXTENSION + HRLZI TT,AF.ALS ;ALL STRUCTURE FLAG + CAMN D,[SIXBIT/ALL/] ;DOES THIS ONE WANT EVRYTHING? + IORM TT,FLG ;YES, REMEMBER + MOVSI D,-4 ;BUMP AOBJN POINTER TO NAME DESCRIPTORS + ADDM D,AOP + HRRZ A,@(P) ;GET CDR + MOVEM A,(P) ;REPLACE OVER OLD POINTER + JUMPN A,DIRNL ;IF NON-NIL THEN READ NEXT NAMELIST + PUSHJ P,GTHDSK ;GATHER DSK: SEARCHLIST + PUSHJ P,GTHSYS ;GATHER SYS: SEARCHLIST + HRLZI T,AF.ALS ;ANY NEED FOR ALL:? + TDNE T,FLG + PUSHJ P,GTHALL ;YUP, WE WILL NEED SO WE WILL GET + MOVE D,AOP ;GET THE NAMELIST POINTER + MOVEM D,PTN ;STORE IN A TEMP LOCATION +DIRWLD: SKIPN (D) ;THIS ENTRY BEEN HACKED? + JRST DIRDON ;YUP, SO IT MAY BE IGNORED + HLRE T,1(D) ;GET LEFT HALF PPN + AOJE T,DIRHWD ;HACK WILD PPN IF -1 + HRRE T,1(D) ;RIGHT HALF + AOJN T,DIRDON ;NO WILD PPN IF NEITHER HALF -1 +DIRHWD: MOVE TT,(D) ;GET THE DEVICE TO HACK + MOVEI TT,HAKMFD ;ROUTINE TO CALL + MOVEM TT,HAK ;REMEMBER FOR LATER + PUSHJ P,OPNDEV ;THEN HACK ALL UFD'S +DIRDON: MOVE T,[4,,4] ;BUMP FOR POINTER + ADDM T,PTN + SKIPGE D,PTN ;GET POINTER, SKIP IF NO ENTRIES REMAIN + JRST DIRWLD ;HACK THE NEXT ENTRY + MOVE D,AOP ;RETRIEVE THE POINTER + MOVEM D,PTN ;SAVE A NEW COPY +DIRPPN: SKIPN TT,(D) ;THIS BEEN DONE BY A WILD ENTRY? + JRST DIRDN1 ;YES, SO IT MAY BE IGNORED + MOVEI T,HAKUFD ;ROUTINE TO CALL + MOVEM T,HAK ;MAKE ACCESSIBLE TO OTHER ROUTINES + PUSHJ P,OPNDEV ;GET THIS DEVICE +DIRDN1: MOVE T,[4,,4] ;POINTER SHOULD BE BUMPED + ADDM T,PTN + SKIPGE D,PTN ;IF POINTER IS STILL OK THEN DON'T SKIP + JRST DIRPPN ;AND TRY FOR NEXT PPN + SUB FLP,[MAXFLP,,MAXFLP] ;RESTORE FLP TO ORIGIONAL STATE + MOVE FXP,ORG ;SAME WITH FXP + SUB P,[3,,3] ;GET RID OF CHANNEL BLOCKS ALLOCATED + POPJ P, ;RETURN AS WE ARE DONE + + SUBTTL Searchlist building routines + +;GTHDSK: Build the JOB's searchlist +GTHDSK: MOVEI D,(FXP) ;WILL BUILD POINTER IN D + PUSH FXP,[-1] ;GET THE FIRST THING FIRST! + HRLZI T,1 ;ONLY DEVICE NAME +DSKNXT: HRRI T,(FXP) ;POINTER FOR JOBSTR UUO + JOBSTR T, ;GET THE INFO + JRST DSKJFL ;JOBSTR FAILED + SKIPN TT,(FXP) ;ARE WE AT THE FENCE? + JRST DSKEND + ADD D,[-1,,0] ;BUMP POINTER + PUSH FXP,TT ;COPY DEVICE NAME FOR NEXT ROUND + JRST DSKNXT +DSKEND: MOVEM D,JSP ;PLANT POINTER IN ITS SPOT + POP FXP,T ;RESTORE STACK TO CORRECT VALUE + POPJ P, + +;GTHSYS: Build the system's searchlist +GTHSYS: MOVEI D,(FXP) ;START BUILDING POINTER + PUSH FXP,[0] ;WE NEED SYSTEM SEARCHLIST + PUSH FXP,. ;IGNORED + PUSH FXP,[-1] ;START FROM FIRST STRUCTURE + HRLZI T,3 ;ALWAYS 3 ARGS + HRRI T,-2(FXP) ;CORRECT POINTER + GOBSTR T, ;GET THE NEXT STRUCTURE + JRST SYSGFL ;GOBSTR FAILURE + SKIPN TT,(FXP) ;ONLY USEFUL IF NON-NULL + JRST SYSEND + MOVEM TT,-2(FXP) ;STORE IN SAFE LOCATION + PUSH FXP,TT ;THEN THE DEVICE + SETZM -2(FXP) ;WE STILL WANT SYSTEM SEARCHLIST + ADD D,[-1,,0] ;BUMP POINTER + JRST SYSNXT ;NOW GET THE NEXT STRUCTURE +SYSEND: MOVEM D,SSP ;REMEMBER POINTER + SUB FXP,[3,,3] ;RETURN STACK TO NORMAL + POPJ P, + +;GTHALL: Build the ALL searchlist +GTHALL: MOVEI D,(FXP) ;START BUILDING POINTER + SETZI T, ;START FROM FIRST STRUCTURE +ALLNXT: SYSSTR T, ;GET THE NEXT STRUCTURE + JRST ALLSFL ;UUO FAILURE! + JUMPE T,ALLEND ;DONE IF NO MORE STRUCTURES + PUSH FXP,T ;ELSE REMEMBER THIS + ADD D,[-1,,0] ;BUMP THE POINTER + JRST ALLNXT ;THEN PROCEED TO NEXT STRUCTURE +ALLEND: MOVEM D,ASP ;STORE THE POINTER + POPJ P, + + SUBTTL Device hacking routines + +;OPNDEV: ROUTINE TO PROCESS DEVICES +;CALLED WITH: DEVICE IN TT +; ROUTINE TO CALL IN -1(P) +; POINTER TO FILE DESCRIPTOR BLOCK IN D +OPNDEV: MOVSS TT ;REVERSE DEVICE NAME FOR FAST CHECKING + CAIN TT,(SIXBIT/DSK/) ;JOB SEARCHLIST? + HRLZI TT,JSP ;YES, POINT TO IT + CAIN TT,(SIXBIT/ALL/) ;EVERY STRUCTURE? + HRLZI TT,ASP ;YES, POINTER TO IT + CAIN TT,(SIXBIT/SYS/) ;SYSTEM SEARCHLIST? + HRLZI TT,SSP ;YES, POINTER TO IT IN FLP + MOVSS TT ;REVERSE HALVES AGAIN + TLNN TT,-1 ;IS IT A POINTER? + JRST OPNPNT ;YES, HANDLE AS LIST OF DEVICES +;ALTERNATE ENTRY-POINT IF NON-MUTIPLE-DEVICE 'DEVICES' (SYS, ALL, DSK) +;ACTUAL DEVICE IN TT IS NOW A GOOD ONE TO USE +OPNNXT: SETZI F, ;CLEAR FLAGS + SKIPN T,JSP ;ANY JOB SEARCHLIST? + JRST $DOSSP ;NOPE, TRY SYSTEM SEARCHLIST +$NXJSP: CAMN TT,(T) ;IS THIS A MATCH? + TROA F,DF.DSK ;YES, SO WE ARE IN DSK: SEARCHLIST + AOBJN T,$NXJSP ;DO ALL ENTRIES +$DOSSP: SKIPN T,SSP ;ANY SYS:? + JRST $DOASP ;NOPE, TRY ALL: SEARCHLIST +$NXSSP: CAMN TT,(T) ;THIS A MATCH? + TROA F,DF.SYS + AOBJN T,$NXSSP +$DOASP: SKIPN T,ASP ;TRY FOR ALL: SEARCHLIST + JRST NMSL ;NONE, SO GO BACK TO CODE +$NXASP: CAMN TT,(T) ;THIS A MATCH ON THE DEVICE? + TROA F,DF.ALL + AOBJN T,$NXASP +NMSL: TRC F,DF.ALL ;MAKE SENSE OF FLAG CORRECT + HRRM F,FLG ;THESE ARE THE FLAGS FOR THIS ROUND + MOVE T,AOP ;POINTER TO ALL NAMELISTS + MOVEI T,HAKMFD ;WE MUST TEST TO SEE WHICH CHANNEL + CAMN T,-1(P) ;ARE WE HACKING AN MFD? + SKIPA T,[MFP] ;YES, USE MFD CHANNEL + MOVE T,[UFP] ;ELSE USE UFD CHANNEL + SKIPE R,@T ;HAVE WE BUILT THE BLOCK YET? + JRST OPNHBK ;YES, WE HAVE THE BLOCK + MOVEI R,(FXP) ;THIS WILL BE THE POINTER + MOVEM R,@T ;SAVE FOR LATER USE + PUSH FXP,TT ;SAVE DEVICE NAME AS FIRST ENTRY + MOVEI R,207 ;WE NEED 1+3+203 WORDS + PUSH FXP, + SOJG R,.-1 ;ALLOCATE WORDS IN TIGHT LOOP + PUSH FXP,T ;SAVE POINTER + PUSHJ P,ALFILE ;GET A CHANNEL ALLOCATED + MOVE B,RPT ;GET POINTER TO WORDS ON P + SKIPN 1(B) ;THIS SLOT BEEN USED? + EXCH A,1(B) ;NOPE, WE CAN USE IT NOW + SKIPE A ;DID WE STORE ALREADY? + MOVEM A,2(B) ;NOPE, DO SO NOW + LSH T,27 ;MOVE CHANNEL # TO AC FIELD + EXCH T,(FXP) ;REMEMBER CHANNEL NUMBER AND RESTORE POINTER + MOVE R,@T ;R MUST HOLD POINTER INTO FXP + POP FXP,1(R) ;THEN PUT CHANNEL NUMBER WHERE IT BELONGS +OPNHBK: PUSH FXP,[14] ;BUILD THE OPEN BLOCK ON FXP + PUSH FXP,TT ;DEVICE NAME + HRLZI T,2(R) ;POINTER TO BUFFER HEADER + PUSH FXP,T ;LAST WORD FOR OPEN + MOVE T,[OPEN -2(FXP)] ;GET THE OPEN INSTRUCTION + IOR T,1(R) ;PLACE IN IT THE CHANNEL NUMBER + XCT T ;THEN PERFORM THE OP + JRST OPNOPF ;FAILURE, WHAT SHOULD WE DO? + MOVEI T,5(R) ;THIS IS WHERE THE BUFFER HAS TO GO + SUB FXP,[3,,3] ;GET RID OF THE OPEN BLOCK + PUSH FXP,.JBFF ;SAVE THE CURRENT FIRST FREE LOCATION + MOVEM T,.JBFF ;KLUDGE IT SO BUFFER GOES IN RIGHT PLACE + MOVE T,[INBUF 1] ;WE WILL TAKE ONE BUFFER + IOR T,1(R) ;THE CORRECT CHANNEL + XCT T ;GET THE BUFFER + POP FXP,.JBFF ;RESTORE .JBFF FOR OTHER PEOPLE TO USE + MOVEM R,DVB ;REMEMBER THE POINTER + PUSHJ P,@HAK ;CALL THE APPROPRIATE ROUTINE + MOVE R,DVB ;RESTORE THE POINTER + MOVE T,[RELEAS] ;WE CAN NOW RID OURSELVES OF THE DEVICE + IOR T,1(R) ;BUT ON THE CORRECT CHANNEL + XCT T ;DO IT + MOVE TT,(R) ;THIS IS THE DEVICE WE JUST HACKED + SETZI F, ;CLEAR FLAGS + SKIPN T,JSP ;ANY JOB SEARCHLIST? + JRST DOSSP ;NOPE, TRY SYSTEM SEARCHLIST +NXTJSP: CAMN TT,(T) ;IS THIS A MATCH? + SETZM (T) ;YES, CLEAR THE DEVICE AS WE HAVE HACKED IT + SKIPE (T) ;IS THERE A DEVICE HERE? + TRO F,DF.DSK ;YES, SO DSK: IS NOT COMPLETELY DONE + AOBJN T,NXTJSP ;THEN DO ALL ENTRIES +DOSSP: TRCN F,DF.DSK ;COMPLEMENT THE SENSE + SETZM JSP ;NO DSK: LEFT SO OPTIMIZE BY CLEARING POINTER + SKIPN T,SSP ;ANY SYS:? + JRST DOASP ;NOPE, TRY ALL: SEARCHLIST +NXTSSP: CAMN TT,(T) ;THIS A MATCH? + SETZM (T) + SKIPE (T) ;A DEVICE HERE? + TRO F,DF.SYS + AOBJN T,NXTSSP +DOASP: TRCN F,DF.SYS ;COMPLEMENT STATE FOR CORRECTNESS LATER ON + SETZM SSP ;NO MORE POINTER NEEDED + SKIPN T,ASP ;TRY FOR ALL: SEARCHLIST + JRST DONDEV ;NONE, SO WE CAN GO THROUGH ALL ENTRIES NOW +NXTASP: CAMN TT,(T) ;THIS A MATCH ON THE DEVICE? + SETZM (T) + SKIPE (T) ;A DEVICE LEFT HERE? + TRO F,DF.ALL + AOBJN T,NXTASP +DONDEV: TRCN F,DF.ALL ;MAKE SENSE OF FLAG CORRECT + SETZM ASP + MOVE T,AOP ;POINTER TO ALL NAMELISTS +NXTBLK:CAME TT,(T) ;IS THIS IDENTICAL DEVICE? + TDNE F,3(T) ;OR IS IT SPECIAL DEVICE THAT IS FINISHED? + SETZM (T) ;YES, REMOVE IT FROM FURTHUR USE + AOBJN T,NXTBLK ;GO ON TILL ALL DONE + POPJ P, ;THEN RETURN TO MAINLINE + +;Handle multiple device pseudo-devices +OPNPNT: SKIPL T,(TT) ;GET THE POINTER IF IT IS THERE + JRST MULDON ;NONE THERE, WE ARE DONE WITH THIS DEVICE +MULNXT: SKIPN TT,(T) ;GET DEVICE IF IT IS STILL THERE + JRST MULBLK ;NOPE, BLANK DEVICE + MOVEM T,MDP ;SAVE THE POINTER + PUSH P,-1(P) ;PUT THE ROUTINE POINTER IN THE CORRECT SPOT + PUSHJ P,OPNNXT ;THEN HANDLE THIS DEVICE + SUB P,[1,,1] ;THROW AWAY THE SAVED POINTER + MOVE T,MDP ;RESTORE THE POINTER INTO LIST OF DEVICES +MULBLK: AOBJN T,MULNXT ;NEXT DEVICE IF ANY LEFT TO DO +MULDON: POPJ P, ;RESTORE WHEN DONE + + SUBTTL Hack MFD routines + +;HAKMFD: Routine to go through the MFD on the currently open device. +; HAKUFD is called for every valid entry in the MFD. +HAKMFD: PUSH FXP,[1,,1] ;THE MFD IS [1,1] + PUSH FXP,[SIXBIT/UFD/] ;IT IS REALLY A SPECIAL UFD + PUSH FXP,[0] + PUSH FXP,[1,,1] ;AND IT IS FOUND IN THE MFD PPN + MOVE T,[LOOKUP -3(FXP)] ;THE LOOKUP UUO + IOR T,1(R) ;PLACE IN THE CHANNEL NUMBER + XCT T ;THEN GET THE MFD + JRST MFDEOF ;WOW! IF NO MFD, THEN JUST SKIP DEVICE + SUB FXP,[4,,4] ;LOOKUP BLOCK NO LONGER NEEDED + SKIPE T,UFP ;SKIP IF NO UFD BLOCK YET + JRST MFDUFD ;WE HAVE THE UFD BLOCK, SO WE ARE OK + MOVEI T,(FXP) ;THIS WILL BE THE POINTER + PUSH FXP,TT ;SAVE THE DEVICE NAME TO BE STANDARD + PUSH FXP,T ;SAVE T OVER ALFILE + PUSHJ P,ALFILE ;GET ANOTHER CHANNEL + MOVE TT,RPT ;GET POINTER + SKIPN 1(TT) ;DID WE USE THIS SLOT? + EXCH A,1(TT) ;NOPE, SO USE IT NOW + SKIPE A ;WAS THE OTHER SLOT OK? + MOVEM A,2(TT) ;NOPE, SO USE THIS ONE + LSH T,27 ;MOVE CHANNEL TO AC FIELD + EXCH T,(FXP) ;THEN RESTORE T AND SAVE CHANNEL + MOVEI TT,206 ;WE NOW NEED ROOM FOR BUFFERS + PUSH FXP,TT ;MAKE ROOM ON STACK FXP + SOJG TT,.-1 ;LOOP UNTIL WE HAVE ENOUGH + MOVEM T,UFP ;ALSO REMEMBER POINTER FOR LATER USE +MFDUFD: PUSH FXP,[14] ;MODE 14 FOR UFD + PUSH FXP,(T) ;THE DEVICE TO OPEN + MOVEI TT,3(T) ;THIS IS WHERE THE BUFFER HEADER IS + PUSH FXP,TT ;PLACE THAT ON THE STACK + MOVE T,[OPEN -2(FXP)] ;THE UUO TO GET THE DEVICE FOR UFD HACKING + IOR TT,1(T) ;PLACE IN THE CORRECT CHANNEL NUMBER + XCT TT ;THEN GET THE DEVICE ON THIS CHANNEL + JRST MFDOPF ;OPEN FAILED, OH WELL + SUB FXP,[3,,3] ;RID OURSELVES OF EXTRA STACK + MOVEI TT,5(T) ;THIS IS WHERE WE WANT OUR BUFFER TO GO + EXCH TT,.JBFF ;MAKE SURE THE MONITOR PUTS IT THERE + PUSH FXP,TT ;SAVE THE OLD ONE AS WE WILL PUT IT BACK LATER + MOVE TT,[INBUF 1] ;WE MUST FORCE ONE BUFFER + IOR TT,1(T) ;MAKE A CORRECT UUO + XCT TT ;GET THE BUFFERS + POP FXP,.JBFF ;THEN RESTORE OLD .JBFF +MFDNXT: SOSG 4(R) ;ANY DATA LEFT IN BUFFER? + JSP T,MFDGET ;TRY TO GET MORE DATA + ILDB TT,3(R) ;GET THE PPN NAME + SOSG 4(R) ;ALSO NEEDED IS AN EXTENSION + JSP T,MFDGET ;MUST BE IN THE NEXT BUFFER + ILDB T,3(R) + HLRZS T ;GET ONLY THE DATA + CAIE T,(SIXBIT/UFD/) ;IS THIS A VALID ENTRY? + JRST MFDNXT ;NOPE, SO GO TO NEXT ENTRY + JUMPE TT,MFDNXT ;IS THERE ANYTHING TO CHECK? + PUSH P,R ;SAVE R OVER UFD HACKING ROUTINE + PUSHJ P,HAKUF1 ;CALL WITH UFD NAME IN TT + POP P,R ;RESTORE POINTER + JRST MFDNXT ;THEN PROCESS NEXT ENTRY +MFDGET: MOVE F,[IN] ;WE NEED TO READ MORE DATA + IOR F,1(R) ;ADD IN THE CHANNEL + XCT F ;ASK THE MONITOR + JRST (T) ;NO ERRORS, SO RETURN + MOVE F,[RELEAS] ;WE MUST ASSUME EOF, SO BYE-BYE TO CHANNEL + MOVE T,UFP ;NO MORE UFD HACKING CHANNEL, GET POINTER + IOR F,1(T) ;USE THE CORRECT CHANNEL + XCT F + POPJ P, + + SUBTTL Hack ufd routines +;HAKUFD: ROUTINE TO GO THROUGH ALL FILES IN A UFD. UFD NAME IN 1(D) +;HAKUF1: ALTERNATE ENTRY, UFD IN TT +HAKUFD: MOVE TT,1(D) ;STANDARDIZE PPN: INTO TT +HAKUF1: PUSH FXP,T ;BUILD A LOOKUP BLOCK + PUSH FXP,[SIXBIT/UFD/] + PUSH FXP,[0] + PUSH FXP,[1,,1] + MOVE R,UFP ;POINTER TO UFD DATA BLOCK + MOVE T,[LOOKUP -3(FXP)] ;WE WANT THIS UFD + IOR T,1(R) ;ON THE CORRECT CHANNEL + XCT T + JRST UFDDON ;MAKE BELIEVE WE ARE DONE IF LOOKUP FAILS +UFDNXT: SOSG 4(R) ;ANY BYTES LEFT? + JSP A,UFDGET ;NOPE, GET MORE OF THEM + ILDB T,3(R) ;GET THE FILENAME INTO T + SOSG 4(R) ;NOW TRY FOR THE EXTENSION + JSP A,UFDGET ;GET MORE DATA + ILDB TT,3(R) ;EXTENSION INTO TT + JUMPE T,UFDNXT ;IGNORE NULL ENTRIES + HLLZS TT ;THROW AWAY MONITOR INTERNAL GARBAGE + PUSHJ P,MATCH ;TRY TO MATCH THIS FILE ENTRY + JRST UFDNXT ;THEN GO ON TO NEXT ONE IN UFD +UFDGET: HRLZI TT,(IN) ;WE CAN ALWAYS USE TT HERE, GET THE INS + IOR TT,1(R) ;PLACE IN THE CORRECT CHANNEL + XCT TT ;DO THE I/O + JRST (A) ;ALL IS WELL +UFDDON: SUB FXP,[4,,4] ;GET RID OF THE LOOKUP BLOCK + HRLZI TT,(CLOSE) ;WE MUST CLOSE THE CHANNEL + IOR TT,1(R) ;THE CORRECT CHANNEL! + XCT TT + POPJ P, ;NOW RETURN TO MAINLINE + + SUBTTL File matching routines + +;MATCH: Here to check a file to see if it matches any request block +; (R): Device +; -7(FXP): PPN +; T: Filename +; TT: Extension +MATCH: PUSH P,R ;SAVE AS WE CANNOT DESTROY IT + PUSH FXP,TT ;SAVE EXTENSION AS WE WILL NEED TT + MOVE R,AOP ;THIS IS THE POINTER TO THE REQUEST BLOCKS +MTCNXT: SKIPN (R) ;ANY ENTRY HERE? + JRST MTCDON ;NOPE, SO DONE + HRRZ F,FLG ;GET THE FLAGS INTO F + TDNE F,3(R) ;ANY DEVICE SPECS IN COMMON? + JRST MTCDEV ;YES, THEN THE DEVICES MATCH + MOVE TT,@(P) ;GET THE DEVICE NAME WE WERE GIVEN + CAME TT,(R) ;DOES THAT MATCH THE CURRENT ENTRY? + JRST MTCDON ;NOPE, THEN THIS ENTRY CANNOT MATCH +MTCDEV: SETZI F, ;CLEAR PPN MASK + HLRE TT,1(R) ;GET THE PROJECT NUMBER OF THE ENTRY + AOSN TT ;WILDCARD? + HRROS F ;YES, FLAG AS SUCH + HRRE TT,1(R) ;NOW CHECK THE PROGRAMMER NUMBER + AOSN TT + HLLOS F + IOR F,-10(FXP) ;MAKE PPN TO CHECK AGAINST + CAME F,1(R) ;THIS MUST MATCH TO BE A WIN + JRST MTCDON + HRLZI TT,(SIXBIT/*/) ;THIS IS THE WILDCARD CHECKER + CAME TT,2(R) ;IS IT A WILDCARD? + CAMN T,2(R) ;OR AN EXACT MATCH FOR THE FILENAME? + SKIPA + JRST MTCDON + HLLZ F,3(R) ;GET ONLY THE EXTENSION FROM THE ENTRY + CAME TT,T ;WILDCARD? + CAMN F,(FXP) ;OR EXACT MATCH FOR THE EXTENSION + SKIPA + JRST MTCDON + PUSH FXP,@(R) ;SAVE THE DEVICE + PUSH FXP,-11(FXP) ;THE PPN + PUSH FXP,T ;THE FILENAME + PUSH FXP,-3(FXP) ;THEN FINALLY THE EXTENSION + PUSHJ P,6BTNML ;THEN CONVERT TO A NAMELIST + MOVE F,FLG ;GET THE FLAGS + TLNE F,AF.ALL ;ANY PROPERTIES TO BE CONS'ED? + PUSHJ P,DOFILE ;PROCESS THE LOOKUP BLOCK IF MORE INFO DESIRED + POP FXP,TT ;RESTORE EXTENSION TO TT + POP P,R ;RESTORE POINTER + POPJ P, +MTCDON: ADD R,[4,,4] ;BUMP POINTER TO NEXT ENTRY + JUMPL R,MTCNXT ;GO ON IF ANY ENTRIES LEFT + POP FXP,TT ;RESTORE THE EXTENSION + POP P,R ;ELSE RESTORE THE OLD POINTER + POPJ P, + + SUBTTL Property CONS'ing routines + +;DOFILE: The main routine. Dispatches to appropriate other routines +; that actually do the work. Also LOOKUP's the file on the +; proper channel. +DOFILE: MOVE R,ELP ;GET THE EXTENDED LOOKUP BLOCK POINTER + SKIPE (R) ;HAS THIS CHANNEL BEEN ALLOCATED? + JRST DOFIL1 ;YES, SO DON'T ALLOCATE IT AGAIN! + PUSHJ P,ALFILE ;ALLOCATE A CHANNEL + MOVEM F,1(R) ;STORE FOR LATER USE + SETOM (R) ;FLAG THAT WE NOW OWN A CHANNEL + MOVE F,RPT ;GET POINTER TO P STACK + MOVEM A,3(F) ;MAKE IT SO GARBAGE COLLECTOR SAVES CHANNEL +DOFIL1: PUSH FXP,[0] ;FOR THE OPEN BLOCK, MODE 0 + PUSH FXP,@UFP ;SAVE THE DEVICE ALSO + PUSH FXP,[0] ;NO BUFFERS NEEDED + MOVE F,[OPEN -2(FXP)] ;OPEN UUO + IOR F,1(R) ;NOW USE THE CORRECT CHANNEL + XCT F + JRST DOFOPF ;AWWW..... + SUB FXP,[3,,3] ;NOW GET RID OF THE OPEN BLOCK + MOVEI TT,ELL ;FIRST ARG FOR EXTENDED LOOKUP + MOVEM TT,2(R) + MOVEM T,3(R) ;PLANT THE FILENAME + MOVE TT,(FXP) ;THE EXTENSION + HLLZM TT,4(R) ;INTO THE CORRECT SPOT +] +FASEND diff --git a/src/l/bltarr.3 b/src/l/bltarr.3 new file mode 100755 index 00000000..41b3a503 --- /dev/null +++ b/src/l/bltarr.3 @@ -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-,[ +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-, + + +IFE .OSMIDAS-,[ +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-, + +IFE .OSMIDAS-,[ +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-, + + +IFE .OSMIDAS-,[ +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-, + + +IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY??? + +DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT +ZZX== +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,[#] + 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 diff --git a/src/l/getmid.18 b/src/l/getmid.18 new file mode 100755 index 00000000..785c2f80 --- /dev/null +++ b/src/l/getmid.18 @@ -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-,[ +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-, + + +IFE .OSMIDAS-,[ +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-, + +IFE .OSMIDAS-,[ +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-, + + +IFE .OSMIDAS-,[ +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-, + + +IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY??? + +DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT +ZZX== +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* +;;; 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 + ++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 diff --git a/src/libdoc/loop.819 b/src/libdoc/loop.819 new file mode 100644 index 00000000..7f7e8098 --- /dev/null +++ b/src/libdoc/loop.819 @@ -0,0 +1,2622 @@ +;;; LOOP -*- Mode:LISP; Package:System-Internals; Base:8; Lowercase:T -*- +;;; ********************************************************************** +;;; ****** Universal ******** LOOP Iteration Macro *********************** +;;; ********************************************************************** +;;; **** (C) COPYRIGHT 1980, 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ******** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ************* +;;; ********************************************************************** + +;;;; LOOP Iteration Macro + +;The master copy of this file is on MC:LSB1;LOOP > (formerly ML:) +;The current Lisp machine copy is on AI:LISPM2;LOOP > +; or more likely on P:>SYS>SYS2>LOOP and OZ:SRC:LOOP +;The FASL and QFASL should also be accessible from LIBLSP; on all machines. +;(Is this necessary anymore? LOOP is now in the Lisp Machine system and +; is accessible on LISP; and distributed with PDP10 Maclisp.) +;Printed documentation is available as MIT-LCS Technical Memo 169, +; "LOOP Iteration Macro", from: +; Publications +; MIT Laboratory for Computer Science +; 545 Technology Square +; Cambridge, MA 02139 +; the text of which appears in only slightly modified form in the Lisp +; Machine manual. + +; Bugs/complaints/suggestions/solicitations-for-documentation to BUG-LOOP +; at any ITS site (MIT-ML preferred). + + +; ********************************************************************** +; *************************** NOTE WELL ******************************** +; ********************************************************************** +;Incremental compiling of things in this file will generate wrong code +; unless you first evaluate the 'feature' stuff on the next page +; ("readtime environment setup"). (This mainly of Lispm interest.) +;This source sincerely believes that it can run compatibly, WITHOUT ANY +; TEXTUAL MODIFICATIONS AT ALL, in PDP-10 Maclisp, Multics Maclisp, Lisp +; Machine Lisp (Zetalisp), VAX NIL, and Franz Lisp. PLEASE do not make +; changes to this file (the master copy) if you are in any way unsure +; of the implications in a dialect you are not very familiar with; let +; a LOOP maintainer take the responsibility for breaking the master copy +; and maintaining some semblance of sanity among the disparities. Note +; in particular that LOOP also runs in the PDP10 Maclisp -> Vax NIL +; cross-compiler; that environment requires LOOP to produce code which +; can at the same time be interpreted in Maclisp, and compiled for NIL. + + +; Bootstrap up our basic primitive environment. +; This includes backquote, sharpsign, defmacro, let. + +(eval-when (eval compile) + (cond ((status feature Multics) + (defun include-for-multics macro (x) + (cons '%include (cdr x)))) + (t (defmacro include-for-multics (&rest ignored) nil)))) + +(include-for-multics lisp_prelude) +(include-for-multics lisp_dcls) + +;;;; Readtime Environment Setup + +;Now set up the readtime conditionalization environment. This won't work +; in any compiler that reads the whole file before compiling anything. +; It is a good idea to pretend that case matters in ALL contexts. +; This is in fact true in Franz at the present. Case matters to Multics +; in symbols, except for in (status feature ). +(eval-when (eval compile) + #+NIL (progn + (defmacro loop-featurep (f) + `(featurep ',f target-features)) + (defmacro loop-nofeaturep (f) + `(nofeaturep ',f target-features)) + (defmacro loop-set-feature (f) + `(set-feature ',f target-features)) + (defmacro loop-set-nofeature (f) + `(set-nofeature ',f target-features)) + ) + #+(and Lispm MIT) + (progn + (defun loop-featurep ("e f) + (xr-feature-present f)) + (defun loop-nofeaturep ("e f) + (not (xr-feature-present f))) + (defun loop-set-feature ("e f) + (unless (mem 'string-equal f *features*) + (push (intern (string f) pkg-keyword-package) + *features*))) + (defun loop-set-nofeature ("e f) + (setq *features* + (del 'string-equal f *features*))) + ) + #-(or NIL (and Lispm MIT)) + (progn + (defmacro loop-featurep (f) + `(status feature ,f)) + (defmacro loop-nofeaturep (f) + ; Multics doesn't have (status nofeature)... + `(not (status feature ,f))) + (defmacro loop-set-feature (f) + `(sstatus feature ,f)) + (defmacro loop-set-nofeature (f) + ; Does this work on Multics??? I think not but we don't use. + `(sstatus nofeature ,f)) + ) + ;Note: NEVER in this file is "PDP-10" a valid feature or substring of + ; a feature. It is NEVER hyphenated. Keep it that way. (This because + ; of continuous lossage with not setting up one or the other of the + ; hyphenated/non-hyphenated one.) + (cond ((and (loop-featurep PDP10) + (loop-featurep NILAID)) + ;Compiling a PDP10 -> NIL cross-compiling LOOP. + ; We check the PDP10 feature first sort of gratuitously so that + ; other implementations don't think we are asking about an undefined + ; feature name. (Vax-NIL specifically.) + (loop-set-feature For-NIL) + (loop-set-nofeature For-Maclisp) + (loop-set-nofeature For-PDP10) + (loop-set-feature Run-in-Maclisp) + (loop-set-feature Run-on-PDP10) + (loop-set-nofeature Franz)) + ((and (loop-featurep Maclisp) (loop-nofeaturep For-NIL)) + ; Standard in-Maclisp for-Maclisp. + (loop-set-feature For-Maclisp) + (loop-set-feature Run-In-Maclisp) + (cond ((loop-nofeaturep Multics) + (loop-set-feature For-PDP10) + (loop-set-feature PDP10) + (loop-set-feature Run-on-PDP10)))) + ((loop-featurep NIL) + ; Real NIL + (loop-set-nofeature PDP10) + (loop-set-nofeature Multics) + (loop-set-nofeature Run-on-PDP10) + (loop-set-nofeature For-PDP10) + (loop-set-nofeature Run-In-Maclisp) + (loop-set-nofeature For-Maclisp)) + ((loop-featurep Lispm)) + ((loop-featurep franz) + ;The "natural" case of features in franz is all lower. + ; Since that is unlike the others used in here, we synonymize + ; the obvious other choice. + (loop-set-feature Franz)) + (t (break loop-implementation-unknown))) + (cond ((or (loop-featurep Lispm) (loop-featurep For-PDP10)) + (loop-set-feature Hairy-Collection)) + (t (loop-set-nofeature Hairy-Collection))) + (cond ((loop-featurep For-PDP10) + (loop-set-feature System-Destructuring)) + (t (loop-set-nofeature System-Destructuring))) + (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm)) + (loop-set-feature Named-PROGs)) + (t (loop-set-nofeature Named-PROGs))) + ;In the following two features, "Local" means the Lisp LOOP will be + ; running in, not the one it is being compiled in. "Targeted" means + ; the Lisp it will be producing code for. (All from the point of view + ; of the running LOOP, you see.) + (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm)) + (loop-set-feature Targeted-Lisp-has-Packages)) + (t (loop-set-nofeature Targeted-Lisp-has-Packages))) + (cond ((or (loop-featurep Franz) (loop-featurep Run-in-Maclisp)) + (loop-set-nofeature Local-Lisp-has-Packages)) + (t (loop-set-feature Local-Lisp-has-Packages))) + ;Meaningful-Type-Declarations means that the declarations are (1) + ; implemented by the compiler and (2) used for something. + ; Assume minimally maclisp-like FIXNUM and FLONUM dcls, for local + ; variables or function results. + (cond ((loop-featurep Run-in-Maclisp) + (loop-set-feature Meaningful-Type-Declarations)) + (t (loop-set-nofeature Meaningful-Type-Declarations))) + ;Hair for 3600 cross-compilation? + (cond ((and (loop-featurep Lispm) (not (loop-featurep 3600.))) + (loop-set-feature Loop-Small-Floatp)) + (t (loop-set-nofeature Loop-Small-Floatp))) + ;Common-Lisp-PROGs is, right now, about the only recognition Loop + ; gives common-lisp. It is used because of the incompatible change + ; made with the "block" construct (with which PROG is implemented), + ; such that RETURN returns from a block (prog) named NIL (= () in NIL), + ; rather than the innermost one. LOOP thus needs to be careful how it + ; goes about returning values (when the loop is named, it must use + ; return-from always). + (cond ((or (loop-featurep For-NIL) (loop-featurep Lispm)) + (loop-set-feature Common-Lisp-PROGs)) + (t (loop-set-nofeature Common-Lisp-PROGs))) + ;Common-Lisp-PROGs imply named-progs: + (cond ((and (loop-featurep Common-Lisp-PROGs) + (not (loop-featurep Named-PROGs))) + (error "Common-Lisp-PROGs and not Named-PROGs??"))) + ;Do macros get a second environment argument? + (cond ((or (loop-featurep NIL) + (and (loop-featurep Lispm) (loop-featurep MIT))) + (loop-set-feature Common-Lisp-MACROs)) + (t (loop-set-nofeature Common-Lisp-MACROs))) + ; -> insert more conditionals here <- + ()) + +#+Franz +(eval-when (eval compile) + (setsyntax #// 143.) ; Make slash be slash + (setsyntax #/\ 2.) ; make backslash alphabetic + ) + + +#+Run-on-PDP10 +(eval-when (compile) + ;Note this hack used when compiled only. + ;Its purpose in life is to save a bit of space in the load-time environment, + ; since loop doesn't actually need the PDP10 Maclisp doublequoted crocks + ; to remember their origin as "strings". + (setsyntax #/" 'macro + '(lambda () + (do ((ch (tyi) (tyi)) (l () (cons ch l))) + ((= ch #/") + (list squid (list 'quote (implode (nreverse l))))) + (and (= ch #//) (setq ch (tyi))))))) + + +;;;; Other basic header stuff + + +; Following isn't needed on Lispm, as loop is installed there (ie, these +; symbols are already in GLOBAL). +#+(and Targeted-Lisp-has-Packages (not Lispm) (not NIL)) +(mapc 'globalize + '("LOOP" ; Major macro + "LOOP-FINISH" ; Handy macro + "DEFINE-LOOP-MACRO" + "DEFINE-LOOP-PATH" ; for users to define paths + "DEFINE-LOOP-SEQUENCE-PATH" ; this too + )) + +#+(or For-NIL For-PDP10) +(herald LOOP) + + +;;;; Macro Environment Setup + +;Wrapper for putting around DEFMACRO etc. forms to determine whether +; they are defined in the compiled output file or not. (It is assumed +; that DEFMACRO forms will be.) Making loop-macro-progn output for loading +; is convenient if loop will have incremental-recompilation done on it. +; (Note, of course, that the readtime environment is NOT set up.) + +#+Lispm +(defmacro loop-macro-progn (&rest forms) + `(progn ,@forms)) +#-Lispm +(eval-when (eval compile) + (defmacro loop-macro-progn (&rest forms) + `(eval-when (eval compile) ,@forms))) + + +; Hack up the stuff for data-types. DATA-TYPE? will always be a macro +; so that it will not require the data-type package at run time if +; all uses of the other routines are conditionalized upon that value. +(eval-when (eval compile) + ; Crock for DATA-TYPE? derives from DTDCL. We just copy it rather + ; than load it in, which requires knowing where it comes from (sigh). + ; + #-Local-Lisp-has-Packages + (defmacro data-type? (x) `(get ,x ':data-type)) + #+Local-Lisp-has-Packages + (defmacro data-type? (frob) + (let ((foo (gensym))) + `((lambda (,foo) + ; NIL croaks if () given to GET... No it doesn't any more! But: + ; Every Lisp should (but doesn't) croak if randomness given to GET + ; LISPM croaks (of course) if randomness given to get-pname + (and (symbolp ,foo) + (or (get ,foo ':data-type) + (and (setq ,foo (intern-soft (get-pname ,foo) "")) + (get ,foo ':data-type))))) + ,frob)))) + +(declare (*lexpr variable-declarations) + ; Multics defaults to free-functional-variable since it is declared + ; special & used as function before it is defined: + (*expr loop-when-it-variable) + (*expr initial-value primitive-type) + #+(or Maclisp Franz) (macros t) ; Defmacro dependency + #+Run-in-Maclisp + (muzzled t) ; I know what i'm doing + ) + +#+Run-on-PDP10 +(declare (mapex ()) + (genprefix loop/|-) + (special squid) + #+(and Run-in-Maclisp For-NIL) ; patch it up + (*expr stringp vectorp vref vector-length) + ) + +#-Run-on-PDP10 +(declare + #+Lispm (setq open-code-map-switch t) + #+Run-in-Maclisp (mapex t) + #+Run-in-Maclisp (genprefix loop-iteration/|-)) + +#+Run-on-PDP10 +(mapc '(lambda (x) + (or (getl x '(subr lsubr fsubr macro fexpr expr autoload)) + ; This dtdcl will sort of work for NIL code generation, + ; if declarations will ignored. + (putprop x '((lisp) dtdcl fasl) 'autoload))) + '(data-type? variable-declarations initial-value primitive-type)) + +(loop-macro-progn + (defmacro loop-copylist* (l) + #+Lispm `(copylist* ,l) + #-Lispm `(append ,l ()))) + + +;;;; Random Macros + +; Error macro. Note that in the PDP10 version we call LOOP-DIE rather +; than ERROR -- there are so many occurences of it in this source that +; it is worth breaking off that function, since calling the lsubr ERROR +; takes more inline code. +(loop-macro-progn + (defmacro loop-simple-error (unquoted-message &optional (datum () datump)) + #+(and Run-In-Maclisp (not Multics)) + (progn (cond ((symbolp unquoted-message)) + ((and (not (atom unquoted-message)) + compiler-state + (eq (car unquoted-message) squid) + (not (atom (setq unquoted-message + (cadr unquoted-message)))) + (eq (car unquoted-message) 'quote) + (symbolp (cadr unquoted-message))) + (setq unquoted-message (cadr unquoted-message))) + (t (error '|Uloze -- LOOP-SIMPLE-ERROR| + (list 'loop-simple-error + unquoted-message datum)))) + (cond (datump `(loop-die ',unquoted-message ,datum)) + (t `(error ',unquoted-message)))) + #+(or Franz Multics) + (progn (or (memq (typep unquoted-message) '(string symbol)) + (error '|Uloze -- | (list 'loop-simple-error + unquoted-message datum))) + `(error ,(let ((l (list "lisp: " unquoted-message + (if datump " -- " "")))) + #+Franz (get_pname (apply 'uconcat l)) + #-Franz (apply 'catenate l)) + . ,(and datump (list datum)))) + #-(or Run-In-Maclisp Franz) + `(ferror () ,(if datump (string-append "~S " unquoted-message) + unquoted-message) + . ,(and datump (list datum)))) + (defmacro loop-warn (unquoted-message &optional (datum nil datump)) + ;In pdp10 maclisp, strip off that dumb squid wrapper for the pseudo-string. + #+(and Run-in-Maclisp (not Multics)) + (cond ((symbolp unquoted-message)) + ((and (not (atom unquoted-message)) + compiler-state + (eq (car unquoted-message) squid) + (not (atom (setq unquoted-message + (cadr unquoted-message)))) + (eq (car unquoted-message) 'quote) + (symbolp (cadr unquoted-message))) + (setq unquoted-message (cadr unquoted-message))) + (t (error '|Uloze -- LOOP-SIMPLE-ERROR| + (list 'loop-warn unquoted-message datum)))) + ;Currently, for everywhere but Lispm, turn newlines in the error message + ; into "; ". + #-Lispm + (progn #+NIL + (when (string-search-char #\newline unquoted-message) + (let ((l (coerce unquoted-message 'list))) + ;Please remember what readtable this file is in. + (do ((ll l (cdr ll))) + ((null ll) (setq unquoted-message (coerce l 'string))) + (when (char= (car ll) ~\return) + (if (char= (cadr ll) ~\linefeed) + (setf (cddr ll) (list* ~/; ~\sp (cddr ll))) + (setf (cdr ll) (list* ~/; ~\sp (cdr ll)))))))) + #-NIL + (let ((l (exploden unquoted-message))) + (do ((ll l (cdr ll))) + ((null ll) (setq unquoted-message (implode l))) + (and (= (car ll) #\newline) + (if (= (cadr ll) #\linefeed) + (rplacd (cdr ll) (list* #/; #\sp (cddr ll))) + (rplacd ll (list* #/; #\sp (cdr ll)))))))) + ;Now, figure out how to display the message with the datum. + #+(and Run-In-Maclisp (not Multics)) + (cond (datump `(format msgfiles ',(format nil '|~~&;LOOP: ~A -- ~~S~~%| + unquoted-message) + ,datum)) + (t `(format msgfiles ,(format nil '|~~&;LOOP: ~A~~%| + unquoted-message)))) + #+Lispm + `(compiler:warn () ,(if datump + (string-append unquoted-message " -- ~{~S~^ ~}") + unquoted-message) + . ,(and datump (list datum))) + + #+(or Franz Multics) + (progn (or (memq (typep unquoted-message) '(string symbol)) + (error '|Uloze -- | (list 'loop-simple-error + unquoted-message datum))) + `(progn + (terpri) + (princ ,(let ((l (list "lisp: " unquoted-message + (if datump " -- " "")))) + #+Franz (get_pname (apply 'uconcat l)) + #-Franz (apply 'catenate l))) + ,.(and datump `((princ ,datum))))) + #+(and For-NIL (not Run-in-Maclisp)) + (if datump + `(warn ,(string-append "LOOP: " unquoted-message " -- ~{~S~^ ~}") + ,datum) + `(warn ',(string-append "LOOP: " unquoted-message))) + #-(or Run-In-Maclisp Franz Lispm For-NIL) + `(format error-output ,(string-append + "~&; LOOP: " + (if datump + (string-append unquoted-message + " -- ~{~S~^ ~}") + unquoted-message)) + . ,(and datump (list datum)))) + ) + + +#+(and Run-in-Maclisp (not Multics)) +(defun loop-die (arg1 arg2) + (error arg1 arg2)) + + +; This is a KLUDGE. But it apparently saves an average of two inline +; instructions per call in the PDP10 version... The ACS prop is +; fairly gratuitous. + +#+Run-on-PDP10 +(progn 'compile + (lap-a-list + '((lap loop-pop-source subr) + (args loop-pop-source (() . 0)) + (hlrz a @ (special loop-source-code)) + (hrrz b @ (special loop-source-code)) + (movem b (special loop-source-code)) + (popj p) + nil)) + (eval-when (compile) + (defprop loop-pop-source 2 acs) + )) + +#-Run-on-PDP10 +(loop-macro-progn + (defmacro loop-pop-source () '(pop loop-source-code))) + +(loop-macro-progn + (defmacro object-that-cares-p (x) + #+(and Lispm Symbolics) `(listp ,x) + #+(or NIL (and Lispm (not Symbolics))) `(consp ,x) + #+PDP10 `(pairp ,x) + #-(or Lispm NIL PDP10) `(eq (typep ,x) 'list))) + +(loop-macro-progn + #+NIL + (progn + (eval-when (eval compile) + (when (macro-function 'loop-gentemp) (fmakunbound 'loop-gentemp))) + (defun loop-gentemp (&optional (pref 'loopvar-)) + (declare (special loop-macro-environment)) + (if (si:compilation-macro-environment-p loop-macro-environment) + (gensym) + (gentemp pref)))) + #-NIL + (defmacro loop-gentemp (&optional (pref ''loopvar-)) + (declare (ignore pref)) + '(gensym))) + + +;;;; Variable defining macros + +;There is some confusion among lisps as to whether or not a file containing +; a DEFVAR will declare the variable when the compiled file is loaded +; into a compiler. LOOP assumes that DEFVAR does so (this is needed for +; various user-accessible variables). DEFIVAR is for "private" variables. +; Note that this is moot for Lispm due to incremental-recompilation support +; anyway. +;Multics lcp has some bug whereby DECLARE and (EVAL-WHEN (COMPILE) ...) +; don't get hacked properly inside of more than one level of +; (PROGN 'COMPILE ...). Thus we hack around DEFVAR and DEFIVAR to bypass +; this lossage. +;Franz DEFVAR does not make the declaration on loading, so we redefine it. + +#+(or Multics Franz) +(loop-macro-progn + (defmacro defvar (name &optional (init nil initp) documentation + &aux (dclform `(and #+Franz (getd 'special) + #-Franz (status feature compiler) + (special ,name)))) + ; For some obscure reason, (DECLARE ...) doesn't take effect within 2 + ; (PROGN 'COMPILE ...)s, but (EVAL-WHEN (COMPILE) ...) does, on Multics. + (eval dclform) ; sigh + (cond ((not initp) dclform) + (t `(progn 'compile + ,dclform + (or (boundp ',name) (setq ,name ,init))))))) + +(loop-macro-progn + ; A DEFVAR alternative - "DEFine Internal VARiable". + (defmacro defivar (name &optional (init () initp)) + ; The Lispm choice here is based on likelihood of incremental compilation. + #+(or Lispm For-NIL) `(defvar ,name ,@(and initp `(,init))) + #+Multics (progn (apply 'special (list name)) + (if initp `(or (boundp ',name) (setq ,name ,init)) + `(progn 'compile))) + #-(or Lispm Multics For-NIL) + `(progn 'compile + (declare (special ,name)) + . ,(and initp `((or (boundp ',name) (setq ,name ,init))))))) + +#+Franz +;Defconst is like defvar but always initializes. +; It happens in this case that we really don't care about the global +; declaration on loading, so actually treat it more like DEFIVAR. +; (This is now in Multics and PDP10 Maclisp, thanks to Maclisp Extensions +; Manual.) +(loop-macro-progn + (defmacro defconst (name init &optional documentation) + `(progn 'compile (declare (special ,name)) (setq ,name ,init)))) + + + +;;;; Setq Hackery + +; Note: LOOP-MAKE-PSETQ is NOT flushable depending on the existence +; of PSETQ, unless PSETQ handles destructuring. Even then it is +; preferable for the code LOOP produces to not contain intermediate +; macros, especially in the PDP10 version. + +(defun loop-make-psetq (frobs) + (and frobs + (loop-make-setq + (list (car frobs) + (if (null (cddr frobs)) (cadr frobs) + `(prog1 ,(cadr frobs) + ,(loop-make-psetq (cddr frobs)))))))) + +#-System-Destructuring +(progn 'compile + +(defvar si:loop-use-system-destructuring? + ()) + +(defivar loop-desetq-temporary) + +; Do we want this??? It is, admittedly, useful... +;(defmacro loop-desetq (&rest x) +; (let ((loop-desetq-temporary ())) +; (let ((setq-form (loop-make-desetq x))) +; (if loop-desetq-temporary +; `((lambda (,loop-desetq-temporary) ,setq-form) ()) +; setq-form)))) + + +(defun loop-make-desetq (x) + ;NIL does not support destructuring LET, however (mainly for LOOP) it + ; supports a DESETQ special-form/macro. We should use that to keep the + ; interpreted code size down, and for better debugging in the interpreter. + #+NIL + (cons (do ((l x (cddr l))) ((null l) 'setq) + (unless (and (not (null (car l))) (symbolp (car l))) + (return 'desetq))) + x) + #-NIL + (if si:loop-use-system-destructuring? + (cons (do ((l x (cddr l))) ((null l) 'setq) + (or (and (not (null (car l))) (symbolp (car l))) + (return 'desetq))) + x) + (do ((x x (cddr x)) (r ()) (var) (val)) + ((null x) (and r (cons 'setq r))) + (setq var (car x) val (cadr x)) + (cond ((and (not (atom var)) + (not (atom val)) + (not (and (memq (car val) + '(car cdr cadr cddr caar cdar)) + (atom (cadr val))))) + (setq x (list* (or loop-desetq-temporary + (setq loop-desetq-temporary + (loop-gentemp 'loop-desetq-))) + val var loop-desetq-temporary (cddr x))))) + (setq r (nconc r (loop-desetq-internal (car x) (cadr x))))))) + +#-NIL ;See above +(defun loop-desetq-internal (var val) + (cond ((null var) ()) + ((atom var) (list var val)) + (t (nconc (loop-desetq-internal (car var) `(car ,val)) + (loop-desetq-internal (cdr var) `(cdr ,val)))))) +); End desetq hackery for #-System-Destructuring + + +(defun loop-make-setq (pairs) + (and pairs + #-System-Destructuring + (loop-make-desetq pairs) + #+System-Destructuring + (cons (do ((l pairs (cddr l))) ((null l) 'setq) + (or (and (car l) (symbolp (car l))) (return 'desetq))) + pairs))) + + +(defvar loop-when-function + #+For-NIL 'when #-For-NIL 'and) + +(defvar loop-unless-function + #+For-NIL 'unless #-For-NIL 'or) + + +(defconst loop-keyword-alist ;clause introducers + '( + #+Named-PROGs + (named loop-do-named) + (initially loop-do-initially) + (finally loop-do-finally) + (nodeclare loop-nodeclare) + (do loop-do-do) + (doing loop-do-do) + (return loop-do-return) + (collect loop-do-collect list) + (collecting loop-do-collect list) + (append loop-do-collect append) + (appending loop-do-collect append) + (nconc loop-do-collect nconc) + (nconcing loop-do-collect nconc) + (count loop-do-collect count) + (counting loop-do-collect count) + (sum loop-do-collect sum) + (summing loop-do-collect sum) + (maximize loop-do-collect max) + (minimize loop-do-collect min) + (always loop-do-always nil) ;Normal, do always + (never loop-do-always t) ; Negate the test on always. + (thereis loop-do-thereis) + (while loop-do-while nil while) ; Normal, do while + (until loop-do-while t until) ; Negate the test on while + (when loop-do-when nil when) ; Normal, do when + (if loop-do-when nil if) ; synonymous + (unless loop-do-when t unless) ; Negate the test on when + (with loop-do-with))) + + +(defconst loop-iteration-keyword-alist + `((for loop-do-for) + (as loop-do-for) + (repeat loop-do-repeat))) + + +(defconst loop-for-keyword-alist ;Types of FOR + '( (= loop-for-equals) + (first loop-for-first) + (in loop-list-stepper car) + (on loop-list-stepper ()) + (from loop-for-arithmetic from) + (downfrom loop-for-arithmetic downfrom) + (upfrom loop-for-arithmetic upfrom) + (below loop-for-arithmetic below) + (to loop-for-arithmetic to) + (being loop-for-being))) + +#+Named-PROGs +(defivar loop-prog-names) + +#+Common-Lisp-MACROs +(defivar loop-macro-environment) ;Second arg to macro functions, + ;passed to macroexpand. + +(defvar loop-path-keyword-alist ()) ; PATH functions +(defivar loop-named-variables) ; see SI:LOOP-NAMED-VARIABLE +(defivar loop-collection-crocks) ; see LOOP-DO-COLLECT etc +(defivar loop-variables) ;Variables local to the loop +(defivar loop-declarations) ; Local dcls for above +(defivar loop-nodeclare) ; but don't declare these +(defivar loop-variable-stack) +(defivar loop-declaration-stack) +#-System-Destructuring +(defivar loop-desetq-crocks) ; see loop-make-variable +#-System-Destructuring +(defivar loop-desetq-stack) ; and loop-translate-1 +(defivar loop-prologue) ;List of forms in reverse order +(defivar loop-wrappers) ;List of wrapping forms, innermost first +(defivar loop-before-loop) +(defivar loop-body) ;.. +(defivar loop-after-body) ;.. for FOR steppers +(defivar loop-epilogue) ;.. +(defivar loop-after-epilogue) ;So COLLECT's RETURN comes after FINALLY +(defivar loop-conditionals) ;If non-NIL, condition for next form in body + ;The above is actually a list of entries of the form + ;(cond (condition forms...)) + ;When it is output, each successive condition will get + ;nested inside the previous one, but it is not built up + ;that way because you wouldn't be able to tell a WHEN-generated + ;COND from a user-generated COND. + ;When ELSE is used, each cond can get a second clause + +(defivar loop-when-it-variable) ;See LOOP-DO-WHEN +(defivar loop-never-stepped-variable) ; see LOOP-FOR-FIRST +(defivar loop-emitted-body?) ; see LOOP-EMIT-BODY, + ; and LOOP-DO-FOR +(defivar loop-iteration-variables) ; LOOP-MAKE-ITERATION-VARIABLE +(defivar loop-iteration-variablep) ; ditto +(defivar loop-collect-cruft) ; for multiple COLLECTs (etc) +(defivar loop-source-code) +(defvar loop-duplicate-code ()) ; see LOOP-OPTIMIZE-DUPLICATED-CODE-ETC + + +;;;; Construct a value return + + +#+Common-Lisp-PROGs +(defun loop-construct-return (form) + (if loop-prog-names + `(return-from ,(car loop-prog-names) ,form) + `(return ,form))) + + +#-Common-Lisp-PROGs +(loop-macro-progn + (defmacro loop-construct-return (form) + ``(return ,,form))) + +;;;; Token Hackery + +;Compare two "tokens". The first is the frob out of LOOP-SOURCE-CODE, +;the second a symbol to check against. + +; Consider having case-independent comparison on Multics. +#+(or Multics Franz) +(progn 'compile + (defmacro si:loop-tequal (x1 x2) + `(eq ,x1 ,x2)) + (defmacro si:loop-tmember (x l) + `(memq ,x ,l)) + (defmacro si:loop-tassoc (x l) + `(assq ,x ,l))) + + +#+Lispm +(progn 'compile + (defun si:loop-tequal (x1 x2) + (and (symbolp x1) (string-equal x1 x2))) + (defun si:loop-tassoc (kwd alist) + (and (symbolp kwd) (ass #'string-equal kwd alist))) + (defun si:loop-tmember (kwd list) + (and (symbolp kwd) (mem #'string-equal kwd list)))) + + +#+Run-on-PDP10 +(progn 'compile + #+For-NIL + (defun si:loop-tequal (x1 x2) + (eq x1 x2)) + #-For-NIL + (progn 'compile + (eval-when (load compile) + (cond ((status feature complr) + ; Gross me out! + (setq macrolist + (cons '(si:loop-tequal + . (lambda (x) (cons 'eq (cdr x)))) + (delq (assq 'si:loop-tequal macrolist) + macrolist))) + (*expr si:loop-tmember si:loop-tassoc)))) + (defun si:loop-tequal (x1 x2) + (eq x1 x2))) + (defun si:loop-tmember (kwd list) + (memq kwd list)) + (defun si:loop-tassoc (kwd alist) + (assq kwd alist)) + ) + +#+(and For-NIL (not Run-in-Maclisp)) +(progn 'compile + (defun si:loop-tequal (kwd1 kwd2) + (and (symbolp kwd1) (string= (symbol-name kwd1) (symbol-name kwd2)))) + (defun si:loop-tassoc (kwd alist) + (cond ((symbolp kwd) + (setq kwd (symbol-name kwd)) + (do ((l alist (cdr l))) ((null l) ()) + (when (string= kwd (symbol-name (caar l))) + (return (car l))))))) + (defun si:loop-tmember (token list) + (cond ((symbolp token) + (setq token (symbol-name token)) + (do ((l list (cdr l))) ((null l)) + (when (string= token (symbol-name (car l))) + (return l))))))) + + +#+PDP10 +(eval-when (eval compile) (setq defmacro-displace-call ())) + +(defmacro define-loop-macro (keyword) + "Makes KEYWORD, which is a LOOP keyword, into a Lisp macro that may +introduce a LOOP form. This facility exists mostly for diehard users of +a predecessor of LOOP. Unconstrained use is not advised, as it tends to +decrease the transportability of the code and needlessly uses up a +function name." + (or (eq keyword 'loop) + (si:loop-tassoc keyword loop-keyword-alist) + (si:loop-tassoc keyword loop-iteration-keyword-alist) + (loop-simple-error "not a loop keyword - define-loop-macro" keyword)) + #+Common-Lisp-MACROs + `(setf (macro-function ',keyword) 'loop-translate) + #-Common-Lisp-MACROs + (subst keyword 'keyword + '(eval-when (compile load eval) + #+(or For-NIL Run-on-PDP10) + (progn (flush-macromemos 'keyword ()) + (flush-macromemos 'loop ())) + #-Run-in-Maclisp + (progn + #+Franz + (putd 'keyword + '(macro (macroarg) (loop-translate macroarg))) + #+(and Lispm MIT) + (deff-macro keyword '(macro . loop-translate)) + #-(or Franz (and Lispm MIT)) + (fset-carefully 'keyword '(macro . loop-translate))) + #+Run-in-Maclisp + (progn (defprop keyword loop-translate macro)) + ))) + +#+PDP10 +(eval-when (eval compile) (setq defmacro-displace-call t)) + +(define-loop-macro loop) + +#+Run-in-Maclisp +(defun (loop-finish macro) (form) + ;This definition solves two problems: + ; (1) wasted address space + ; (2) displacing of a form which might tend to be pure. + ; There is little point in macro-memoizing a constant anyway. + (and (cdr form) (loop-simple-error "Wrong number of args" form)) + '(go end-loop)) + +#-Run-in-Maclisp +(defmacro loop-finish () + "Causes the iteration to terminate /"normally/", the same as implicit +termination by an iteration driving clause, or by use of WHILE or +UNTIL -- the epilogue code (if any) will be run, and any implicitly +collected result will be returned as the value of the LOOP." + '(go end-loop)) + + +(defun loop-translate (x #+Common-Lisp-MACROs loop-macro-environment) + #+Common-Lisp-MACROs (loop-translate-1 x) + #-Common-Lisp-MACROs + (progn #-(or For-NIL Run-on-PDP10) (displace x (loop-translate-1 x)) + #+(or For-NIL Run-on-PDP10) + (or (macrofetch x) (macromemo x (loop-translate-1 x) 'loop)))) + + +(defun loop-end-testify (list-of-forms) + (if (null list-of-forms) () + `(,loop-when-function + ,(if (null (cdr (setq list-of-forms (nreverse list-of-forms)))) + (car list-of-forms) + (cons 'or list-of-forms)) + (go end-loop)))) + +(defun loop-optimize-duplicated-code-etc (&aux before after groupa groupb a b + lastdiff) + (do ((l1 (nreverse loop-before-loop) (cdr l1)) + (l2 (nreverse loop-after-body) (cdr l2))) + ((equal l1 l2) + (setq loop-body (nconc (delq '() l1) (nreverse loop-body)))) + (push (car l1) before) (push (car l2) after)) + (cond ((not (null loop-duplicate-code)) + (setq loop-before-loop (nreverse (delq () before)) + loop-after-body (nreverse (delq () after)))) + (t (setq loop-before-loop () loop-after-body () + before (nreverse before) after (nreverse after)) + (do ((bb before (cdr bb)) (aa after (cdr aa))) + ((null aa)) + (cond ((not (equal (car aa) (car bb))) (setq lastdiff aa)) + ((not (si:loop-simplep (car aa))) ;Mustn't duplicate + (return ())))) + (cond (lastdiff ;Down through lastdiff should be duplicated + (do () (()) + (and (car before) (push (car before) loop-before-loop)) + (and (car after) (push (car after) loop-after-body)) + (setq before (cdr before) after (cdr after)) + (and (eq after (cdr lastdiff)) (return ()))) + (setq loop-before-loop (nreverse loop-before-loop) + loop-after-body (nreverse loop-after-body)))) + (do ((bb (nreverse before) (cdr bb)) + (aa (nreverse after) (cdr aa))) + ((null aa)) + (setq a (car aa) b (car bb)) + (cond ((and (null a) (null b))) + ((equal a b) + (loop-output-group groupb groupa) + (push a loop-body) + (setq groupb () groupa ())) + (t (and a (push a groupa)) (and b (push b groupb))))) + (loop-output-group groupb groupa))) + (and loop-never-stepped-variable + (push `(setq ,loop-never-stepped-variable ()) loop-after-body)) + ()) + + +(defun loop-output-group (before after) + (and (or after before) + (let ((v (or loop-never-stepped-variable + (setq loop-never-stepped-variable + (loop-make-variable + (loop-gentemp 'loop-iter-flag-) 't ()))))) + (push (cond ((not before) + `(,loop-unless-function ,v (progn . ,after))) + ((not after) + `(,loop-when-function ,v (progn . ,before))) + (t `(cond (,v . ,before) (t . ,after)))) + loop-body)))) + + +(defun loop-translate-1 (loop-source-code) + (and (eq (car loop-source-code) 'loop) + (setq loop-source-code (cdr loop-source-code))) + (do ((loop-iteration-variables ()) + (loop-iteration-variablep ()) + (loop-variables ()) + (loop-nodeclare ()) + (loop-named-variables ()) + (loop-declarations ()) + #-System-Destructuring + (loop-desetq-crocks ()) + (loop-variable-stack ()) + (loop-declaration-stack ()) + #-System-destructuring + (loop-desetq-stack ()) + (loop-prologue ()) + (loop-wrappers ()) + (loop-before-loop ()) + (loop-body ()) + (loop-emitted-body? ()) + (loop-after-body ()) + (loop-epilogue ()) + (loop-after-epilogue ()) + (loop-conditionals ()) + (loop-when-it-variable ()) + (loop-never-stepped-variable ()) + #-System-Destructuring + (loop-desetq-temporary ()) + #+Named-PROGs + (loop-prog-names ()) + (loop-collect-cruft ()) + (loop-collection-crocks ()) + (keyword) + (tem) + (progvars)) + ((null loop-source-code) + (and loop-conditionals + (loop-simple-error "Hanging conditional in loop macro" + (caadar loop-conditionals))) + (loop-optimize-duplicated-code-etc) + (loop-bind-block) + (setq progvars loop-collection-crocks) + #-System-Destructuring + (and loop-desetq-temporary (push loop-desetq-temporary progvars)) + (setq tem `(prog #+Named-PROGs ,.loop-prog-names + ,progvars + #+Hairy-Collection + ,.(do ((l loop-collection-crocks (cddr l)) + (v () (cons `(loop-collect-init + ,(cadr l) ,(car l)) + v))) + ((null l) v)) + ,.(nreverse loop-prologue) + ,.loop-before-loop + next-loop + ,.loop-body + ,.loop-after-body + (go next-loop) + ; Multics complr notices when end-loop is not gone + ; to. So we put in a dummy go. This does not generate + ; extra code, at least in the simple example i tried, + ; but it does keep it from complaining about unused + ; go tag. + #+Multics (go end-loop) + end-loop + ,.(nreverse loop-epilogue) + ,.(nreverse loop-after-epilogue))) + (do ((vars) (dcls) #-System-Destructuring (crocks)) + ((null loop-variable-stack)) + (setq vars (car loop-variable-stack) + loop-variable-stack (cdr loop-variable-stack) + dcls (car loop-declaration-stack) + loop-declaration-stack (cdr loop-declaration-stack) + tem (ncons tem)) + #-System-Destructuring + (and (setq crocks (pop loop-desetq-stack)) + (push (loop-make-desetq crocks) tem)) + (and dcls (push (cons 'declare dcls) tem)) + (cond ((do ((l vars (cdr l))) ((null l) ()) + (and (not (atom (car l))) + (or (null (caar l)) (not (symbolp (caar l)))) + (return t))) + (setq tem `(let ,(nreverse vars) ,.tem))) + (t (let ((lambda-vars ()) (lambda-vals ())) + (do ((l vars (cdr l)) (v)) ((null l)) + (cond ((atom (setq v (car l))) + (push v lambda-vars) + (push () lambda-vals)) + (t (push (car v) lambda-vars) + (push (cadr v) lambda-vals)))) + (setq tem `((lambda ,lambda-vars ,.tem) + ,.lambda-vals)))))) + (do ((l loop-wrappers (cdr l))) ((null l)) + (setq tem (append (car l) (ncons tem)))) + tem) + (if (symbolp (setq keyword (car loop-source-code))) + (loop-pop-source) + (setq keyword 'do)) + (if (setq tem (si:loop-tassoc keyword loop-keyword-alist)) + (apply (cadr tem) (cddr tem)) + (if (setq tem (si:loop-tassoc + keyword loop-iteration-keyword-alist)) + (loop-hack-iteration tem) + (if (si:loop-tmember keyword '(and else)) + ; Alternative is to ignore it, ie let it go around to the + ; next keyword... + (loop-simple-error + "secondary clause misplaced at top level in LOOP macro" + (list keyword (car loop-source-code) + (cadr loop-source-code))) + (loop-simple-error + "unknown keyword in LOOP macro" keyword)))))) + + +(defun loop-bind-block () + (cond ((not (null loop-variables)) + (push loop-variables loop-variable-stack) + (push loop-declarations loop-declaration-stack) + (setq loop-variables () loop-declarations ()) + #-System-Destructuring + (progn (push loop-desetq-crocks loop-desetq-stack) + (setq loop-desetq-crocks ()))))) + + +;Get FORM argument to a keyword. Read up to atom. PROGNify if necessary. +(defun loop-get-progn-1 () + (do ((forms (ncons (loop-pop-source)) (cons (loop-pop-source) forms)) + (nextform (car loop-source-code) (car loop-source-code))) + ((atom nextform) (nreverse forms)))) + +(defun loop-get-progn () + (let ((forms (loop-get-progn-1))) + (if (null (cdr forms)) (car forms) (cons 'progn forms)))) + +(defun loop-get-form (for) +; (let ((forms (loop-get-progn-1))) +; (cond ((null (cdr forms)) (car forms)) +; (t (loop-warn +;"The use of multiple forms with an implicit PROGN in this context +;is considered obsolete, but is still supported for the time being. +;If you did not intend to use multiple forms here, you probably omitted a DO. +;If the use of multiple forms was intentional, put a PROGN in your code. +;The offending clause" +; (if (atom for) (cons for forms) (append for forms))) +; (cons 'progn forms)))) + (loop-pop-source)) + + +;Note that this function is not absolutely general. For instance, in Maclisp, +; the functions < and > can only take 2 args, whereas greaterp and lessp +; may take any number. Also, certain of the generic functions behave +; differently from the type-specific ones in "degenerate" cases, like +; QUOTIENT or DIFFERENCE of one arg. +;And of course one always must be careful doing textual substitution. +(defun loop-typed-arith (substitutable-expression data-type) + #-(or Lispm Franz) + (if (setq data-type (car (si:loop-tmember (if (data-type? data-type) + (primitive-type data-type) + data-type) + '(fixnum flonum)))) + (sublis (cond ((eq data-type 'fixnum) + #+For-NIL + '((plus . +&) (add1 . 1+&) + (difference . -&) (sub1 . 1-&) + (quotient . //&) (remainder . \&) (times . *&) + (zerop . zerop&) (plusp . plusp&) + (minusp . minusp&) + (greaterp . >&) (lessp . <&) + (min . min&) (max . max&)) + #-For-NIL + '((plus . +) (add1 . 1+) + (difference . -) (sub1 . 1-) + (quotient . //) (remainder . \) (times . *) + (greaterp . >) (lessp . <))) + (t #+For-NIL + '((plus . +$) (difference . -$) + (add1 . 1+$) (sub1 . 1-$) + (quotient . //$) (times . *$) + (greaterp . >$) (lessp . <$) + (max . max$) (min . min$)) + #-For-NIL + '((plus . +$) (difference . -$) + (add1 . 1+$) (sub1 . 1-$) + (quotient . //$) (times . *$) + (greaterp . >) (lessp . <)))) + substitutable-expression) + substitutable-expression) + #+Lispm + (progn data-type substitutable-expression) + #+Franz + (if (si:loop-tequal data-type 'fixnum) + (sublis '((add1 . 1+) (sub1 . 1-) (plus . +) (difference . -) + (times . *) (quotient . //) (remainder . \)) + substitutable-expression) + substitutable-expression) + ) + +(defvar loop-floating-point-types + #+(or For-NIL Lispm) + '(flonum float short-float single-float double-float long-float + #+Loop-Small-Floatp small-flonum) + #-(or For-NIL Lispm) + '(flonum float #+Loop-Small-Floatp small-flonum) + ) + +(defun loop-typed-init (data-type) + (let ((tem nil)) + (cond ((data-type? data-type) (initial-value data-type)) + ((si:loop-tmember data-type '(fixnum integer number)) 0) + ((setq tem (car (si:loop-tmember + data-type loop-floating-point-types))) + #+(or For-NIL Lispm) + (cond ((memq tem '(flonum float)) 0.0) + (t #+Run-in-Maclisp `(coerce 0 ',tem) + #-Run-in-Maclisp (coerce 0 tem))) + #-(or For-NIL Lispm) + (progn #+Loop-Small-Floatp + (cond ((eq data-type 'small-flonum) + #.(and (loop-featurep Loop-Small-Floatp) + (small-float 0))) + (t 0.0)) + #-Loop-Small-Floatp 0.0))))) + + +(defun loop-make-variable (name initialization dtype) + (cond ((null name) + (cond ((not (null initialization)) + (push (list #+Lispm 'ignore + #+(or Multics For-NIL) + (setq name (loop-gentemp 'loop-ignore-)) + #-(or Lispm Multics NIL) () + initialization) + loop-variables) + #+(and For-NIL (not Run-in-Maclisp)) + (push `(ignore ,name) loop-declarations) + #+Multics (push `(progn ,name) loop-prologue)))) + ((atom name) + (cond (loop-iteration-variablep + (if (memq name loop-iteration-variables) + (loop-simple-error + "Duplicated iteration variable somewhere in LOOP" + name) + (push name loop-iteration-variables))) + ((assq name loop-variables) + (loop-simple-error + "Duplicated var in LOOP bind block" name))) + (or (symbolp name) + (loop-simple-error "Bad variable somewhere in LOOP" name)) + (loop-declare-variable name dtype) + ; We use ASSQ on this list to check for duplications (above), + ; so don't optimize out this list: + (push (list name (or initialization (loop-typed-init dtype))) + loop-variables)) + (initialization + #+System-Destructuring + (progn (loop-declare-variable name dtype) + (push (list name initialization) loop-variables)) + #-System-Destructuring + (cond (si:loop-use-system-destructuring? + (loop-declare-variable name dtype) + (push (list name initialization) loop-variables)) + (t (let ((newvar (loop-gentemp 'loop-destructure-))) + (push (list newvar initialization) loop-variables) + ; LOOP-DESETQ-CROCKS gathered in reverse order. + (setq loop-desetq-crocks + (list* name newvar loop-desetq-crocks)) + (loop-make-variable name () dtype))))) + (t (let ((tcar) (tcdr)) + (if (atom dtype) (setq tcar (setq tcdr dtype)) + (setq tcar (car dtype) tcdr (cdr dtype))) + (loop-make-variable (car name) () tcar) + (loop-make-variable (cdr name) () tcdr)))) + name) + + +(defun loop-make-iteration-variable (name initialization dtype) + (let ((loop-iteration-variablep 't)) + (loop-make-variable name initialization dtype))) + + +(defun loop-declare-variable (name dtype) + (cond ((or (null name) (null dtype)) ()) + ((symbolp name) + (cond ((memq name loop-nodeclare)) + #+Multics + ; local type dcls of specials lose. This doesn't work + ; for locally-declared specials. + ((get name 'special)) + ((data-type? dtype) + (setq loop-declarations + (append (variable-declarations dtype name) + loop-declarations))) + #+Meaningful-Type-Declarations + (t #+For-Maclisp + (and (si:loop-tmember dtype '(fixnum flonum)) + (push `(,dtype ,name) loop-declarations)) + #-For-Maclisp + (push `(type ,dtype ,name) loop-declarations)))) + ((object-that-cares-p name) + (cond ((object-that-cares-p dtype) + (loop-declare-variable (car name) (car dtype)) + (loop-declare-variable (cdr name) (cdr dtype))) + (t (loop-declare-variable (car name) dtype) + (loop-declare-variable (cdr name) dtype)))) + (t (loop-simple-error "can't hack this" + (list 'loop-declare-variable name dtype))))) + + +#+For-PDP10 +(declare (special squid)) + +(defun loop-constantp (form) + #+(or NIL (and Lispm MIT)) (constantp form) + #-(or NIL (and Lispm MIT)) + (or (null form) + (eq form 't) + (numberp form) + #-For-PDP10 (stringp form) + (and (not (atom form)) + #-Run-on-PDP10 (eq (car form) 'quote) + #+Run-on-PDP10 (or (eq (car form) 'quote) + ; SQUID implies quoting. + (and compiler-state (eq (car form) squid)))) + )) + +(defun loop-maybe-bind-form (form data-type?) + ; Consider implementations which will not keep EQ quoted constants + ; EQ after compilation & loading. + ; Note FUNCTION is not hacked, multiple occurences might cause the + ; compiler to break the function off multiple times! + ; Hacking it probably isn't too important here anyway. The ones that + ; matter are the ones that use it as a stepper (or whatever), which + ; handle it specially. + (if (loop-constantp form) form + (loop-make-variable (loop-gentemp 'loop-bind-) form data-type?))) + + +(defun loop-optional-type () + (let ((token (car loop-source-code))) + (and (not (null token)) + (or (not (atom token)) + (data-type? token) + (si:loop-tmember token '(fixnum integer number notype)) + (si:loop-tmember token loop-floating-point-types)) + (loop-pop-source)))) + + +;Incorporates conditional if necessary +(defun loop-make-conditionalization (form) + (cond ((not (null loop-conditionals)) + (rplacd (last (car (last (car (last loop-conditionals))))) + (ncons form)) + (cond ((si:loop-tequal (car loop-source-code) 'and) + (loop-pop-source) + ()) + ((si:loop-tequal (car loop-source-code) 'else) + (loop-pop-source) + ;; If we are already inside an else clause, close it off + ;; and nest it inside the containing when clause + (let ((innermost (car (last loop-conditionals)))) + (cond ((null (cddr innermost))) ;Now in a WHEN clause, OK + ((null (cdr loop-conditionals)) + (loop-simple-error "More ELSEs than WHENs" + (list 'else (car loop-source-code) + (cadr loop-source-code)))) + (t (setq loop-conditionals (cdr (nreverse loop-conditionals))) + (rplacd (last (car (last (car loop-conditionals)))) + (ncons innermost)) + (setq loop-conditionals (nreverse loop-conditionals))))) + ;; Start a new else clause + (rplacd (last (car (last loop-conditionals))) + (ncons (ncons ''t))) + ()) + (t ;Nest up the conditionals and output them + (do ((prev (car loop-conditionals) (car l)) + (l (cdr loop-conditionals) (cdr l))) + ((null l)) + (rplacd (last (car (last prev))) (ncons (car l)))) + (prog1 (car loop-conditionals) + (setq loop-conditionals ()))))) + (t form))) + +(defun loop-pseudo-body (form &aux (z (loop-make-conditionalization form))) + (cond ((not (null z)) + (cond (loop-emitted-body? (push z loop-body)) + (t (push z loop-before-loop) (push z loop-after-body)))))) + +(defun loop-emit-body (form) + (setq loop-emitted-body? 't) + (loop-pseudo-body form)) + + +#+Named-PROGs +(defun loop-do-named () + (let ((name (loop-pop-source))) + (or (and name (symbolp name)) + (loop-simple-error "Bad name for your loop construct" name)) + ;If this don't come first, LOOP will be confused about how to return + ; from the prog when it tries to generate such code (as is necessary + ; under #+Common-Lisp-PROGs). + ;Should this error check be made always? + #+Common-Lisp-PROGs + (and (or loop-before-loop loop-body loop-after-epilogue) + (loop-simple-error "NAMED clause occurs too late" name)) + (and (cdr (setq loop-prog-names (cons name loop-prog-names))) + (loop-simple-error "Too many names for your loop construct" + loop-prog-names)))) + +(defun loop-do-initially () + (push (loop-get-progn) loop-prologue)) + +(defun loop-nodeclare (&aux (varlist (loop-pop-source))) + (or (null varlist) + (object-that-cares-p varlist) + (loop-simple-error "Bad varlist to nodeclare loop clause" varlist)) + (setq loop-nodeclare (append varlist loop-nodeclare))) + +(defun loop-do-finally () + (push (loop-get-progn) loop-epilogue)) + +(defun loop-do-do () + (loop-emit-body (loop-get-progn))) + +(defun loop-do-return () + (loop-pseudo-body (loop-construct-return (loop-get-form 'return)))) + + +;;;; List Collection + +; The way we collect (list-collect) things is to bind two variables. +; One is the final result, and is accessible for value during the +; loop compuation. The second is the "tail". In implementations where +; we can do so, the tail var is initialized to a locative of the first, +; such that it can be updated with RPLACD. In other implementations, +; the update must be conditionalized (on whether or not the tail is NIL). + +; For PDP10 Maclisp: +; The "value cell" of a special variable is a (pseudo) list cell, the CDR +; of which is the value. Hence the abovementioned tail variable gets +; initialized to this. (It happens to be the CDAR of the symbol.) +; For local variables in compiled code, the Maclisp compiler implements +; a (undocumented private) form of the +; "(setq tail (variable-location var))" construct; specifically, it +; is of the form (#.gofoo var tail). This construct must appear in +; the binding environment those variables are bound in, currently. +; Note that this hack only currently works for local variables, so loop +; has to check to see if the variable is special. It is anticipated, +; however, that the compiler will be able to do this all by itself +; at some point. + +#+For-PDP10 + (progn 'compile + (cond ((status feature complr) + (setq loop-specvar-hack ((lambda (obarray) + (implode '(s p e c v a r s))) + sobarray)) + (defun loop-collect-init-compiler (form) + (cond ((memq compiler-state '(toplevel maklap)) + ; We are being "toplevel" macro expanded. + ; We MUST expand into something which can be + ; evaluated without loop, in the interpreter. + `(setq ,(caddr form) (munkam (value-cell-location + ',(cadr form))))) + ((or specials + (get (cadr form) 'special) + (assq (cadr form) (symeval loop-specvar-hack))) + `(setq ,(caddr form) (cdar ',(cadr form)))) + (t (cons gofoo (cdr form))))) + (push '(loop-collect-init . loop-collect-init-compiler) + macrolist))) + (defun loop-collect-init fexpr (x) + (set (cadr x) (cdar (car x))))) + +#+(and Hairy-Collection (not For-PDP10)) +(defmacro loop-collect-init (var1 var2) + #+Lispm ;***** Remove kludgey fboundp when everyone up-to-date ***** + `(setq ,var2 ,(if (fboundp 'variable-location) + `(variable-location ,var1) + `(value-cell-location ',var1))) + #-Lispm `(setq ,var2 (munkam (value-cell-location ',var1)))) + + +(defun loop-do-collect (type) + (let ((var) (form) (tem) (tail) (dtype) (cruft) (rvar) + (ctype (cond ((memq type '(max min)) 'maxmin) + ((memq type '(nconc list append)) 'list) + ((memq type '(count sum)) 'sum) + (t (loop-simple-error + "unrecognized LOOP collecting keyword" type))))) + (setq form (loop-get-form type) dtype (loop-optional-type)) + (cond ((si:loop-tequal (car loop-source-code) 'into) + (loop-pop-source) + (setq rvar (setq var (loop-pop-source))))) + ; CRUFT will be (varname ctype dtype var tail (optional tem)) + (cond ((setq cruft (assq var loop-collect-cruft)) + (cond ((not (eq ctype (car (setq cruft (cdr cruft))))) + (loop-simple-error + "incompatible LOOP collection types" + (list ctype (car cruft)))) + ((and dtype (not (eq dtype (cadr cruft)))) + ;Conditional should be on data-type reality + #+Run-in-Maclisp + (loop-simple-error + "Unequal data types in multiple collections" + (list dtype (cadr cruft) (car cruft))) + #-Run-in-Maclisp + (ferror () "~A and ~A Unequal data types into ~A" + dtype (cadr cruft) (car cruft)))) + (setq dtype (car (setq cruft (cdr cruft))) + var (car (setq cruft (cdr cruft))) + tail (car (setq cruft (cdr cruft))) + tem (cadr cruft)) + (and (eq ctype 'maxmin) + (not (atom form)) (null tem) + (rplaca (cdr cruft) + (setq tem (loop-make-variable + (loop-gentemp 'loop-maxmin-) + () dtype))))) + (t (and (null dtype) + (setq dtype (cond ((eq type 'count) 'fixnum) + ((memq type '(min max sum)) 'number)))) + (or var (push (loop-construct-return (setq var (loop-gentemp))) + loop-after-epilogue)) + (or (eq ctype 'list) (loop-make-iteration-variable var () dtype)) + (setq tail + (cond ((eq ctype 'list) + #-(or Hairy-Collection NIL) + (setq tem (loop-make-variable + (loop-gentemp) () ())) + #+NIL + (progn + ;We don't need the tail, actually. + (push `(%with-list-collection ,var) + loop-wrappers) + nil) + #-NIL + (car (setq loop-collection-crocks + (list* (loop-gentemp + 'loop-collect-tail-) + var + loop-collection-crocks)))) + ((eq ctype 'maxmin) + (or (atom form) + (setq tem (loop-make-variable + (loop-gentemp) () dtype))) + (loop-make-variable + (loop-gentemp 'loop-maxmin-fl-) ''t ())))) + (push (list rvar ctype dtype var tail tem) + loop-collect-cruft))) + (loop-emit-body + (caseq type + (count (setq tem `(setq ,var (,(loop-typed-arith 'add1 dtype) + ,var))) + (if (or (eq form 't) (equal form ''t)) + tem + `(,loop-when-function ,form ,tem))) + (sum `(setq ,var (,(loop-typed-arith 'plus dtype) ,form ,var))) + ((max min) + (let ((forms ()) (arglist ())) + ; TEM is temporary, properly typed. + (and tem (setq forms `((setq ,tem ,form)) form tem)) + (setq arglist (list var form)) + (push (if (si:loop-tmember dtype '(fixnum flonum + #+Loop-Small-Floatp + small-flonum)) + ; no contagious arithmetic + `(,loop-when-function + (or ,tail + (,(loop-typed-arith + (if (eq type 'max) 'lessp 'greaterp) + dtype) + . ,arglist)) + (setq ,tail () . ,arglist)) + ; potentially contagious arithmetic -- must use + ; MAX or MIN so that var will be contaminated + `(setq ,var (cond (,tail (setq ,tail ()) ,form) + ((,type . ,arglist))))) + forms) + (if (cdr forms) (cons 'progn (nreverse forms)) (car forms)))) + (t (caseq type + (list (setq form (list 'list form))) + (append (or (and (not (atom form)) (eq (car form) 'list)) + (setq form #+Lispm `(copylist* ,form) + #+For-NIL `(copy-list ,form) + #-(or Lispm For-NIL) + `(append ,form ()))))) + #+Hairy-Collection + (let ((q `(rplacd ,tail ,form))) + (cond ((and (not (atom form)) (eq (car form) 'list) + (not (null (cdr form)))) + ; RPLACD of cdr-coded list: + #+Lispm + (rplaca (cddr q) + (if (cddr form) `(list* ,@(cdr form) ()) + `(ncons ,(cadr form)))) + ;To extract the best code from the compiler: + ;pdp-10 Maclisp prefers (setq var (cdr (rplacd var form))) + ;3600 prefers (rplacd var (setq var form)) + ;LM-2 is epsilonically better with the latter + (cond #+Lispm + ((null (cddr form)) + (rplaca (cddr q) + `(setq ,tail ,(caddr q))) + q) + (t `(setq ,tail ,(loop-cdrify (cdr form) q))))) + (t `(and (cdr ,q) + (setq ,tail (last (cdr ,tail))))))) + #+NIL `(%list-collect-rplacd ,var ,form) + #-(or Hairy-Collection NIL) + (let ((q `(cond (,tail (cdr (rplacd ,tail ,tem))) + ((setq ,var ,tem))))) + (if (and (not (atom form)) (eq (car form) 'list) (cdr form)) + `(setq ,tem ,form ,tail ,(loop-cdrify (cddr form) q)) + `(and (setq ,tem ,form) (setq ,tail (last ,q)))))))))) + + +(defun loop-cdrify (arglist form) + (do ((size (length arglist) (- size 4))) + ((< size 4) + (if (zerop size) form + (list (cond ((= size 1) 'cdr) ((= size 2) 'cddr) (t 'cdddr)) + form))) + #+Meaningful-Type-Declarations (declare (fixnum size)) + (setq form (list 'cddddr form)))) + + + +(defun loop-do-while (negate? kwd &aux (form (loop-get-form kwd))) + (and loop-conditionals (loop-simple-error + "not allowed inside LOOP conditional" + (list kwd form))) + (loop-pseudo-body `(,(if negate? loop-when-function loop-unless-function) + ,form (go end-loop)))) + + +(defun loop-do-when (negate? kwd) + (let ((form (loop-get-form kwd)) (cond)) + (cond ((si:loop-tequal (cadr loop-source-code) 'it) + ;WHEN foo RETURN IT and the like + (setq cond `(setq ,(loop-when-it-variable) ,form)) + (setq loop-source-code ;Plug in variable for IT + (list* (car loop-source-code) + loop-when-it-variable + (cddr loop-source-code)))) + (t (setq cond form))) + (and negate? (setq cond `(not ,cond))) + (setq loop-conditionals (nconc loop-conditionals `((cond (,cond))))))) + +(defun loop-do-with () + (do ((var) (equals) (val) (dtype)) (()) + (setq var (loop-pop-source) equals (car loop-source-code)) + (cond ((si:loop-tequal equals '=) + (loop-pop-source) + (setq val (loop-get-form (list 'with var '=)) dtype ())) + ((or (si:loop-tequal equals 'and) + (si:loop-tassoc equals loop-keyword-alist) + (si:loop-tassoc equals loop-iteration-keyword-alist)) + (setq val () dtype ())) + (t (setq dtype (loop-optional-type) equals (car loop-source-code)) + (cond ((si:loop-tequal equals '=) + (loop-pop-source) + (setq val (loop-get-form (list 'with var dtype '=)))) + ((and (not (null loop-source-code)) + (not (si:loop-tassoc equals loop-keyword-alist)) + (not (si:loop-tassoc + equals loop-iteration-keyword-alist)) + (not (si:loop-tequal equals 'and))) + (loop-simple-error "Garbage where = expected" equals)) + (t (setq val ()))))) + (loop-make-variable var val dtype) + (if (not (si:loop-tequal (car loop-source-code) 'and)) (return ()) + (loop-pop-source))) + (loop-bind-block)) + +(defun loop-do-always (negate?) + (let ((form (loop-get-form 'always))) + (loop-emit-body #+For-NIL `(,(if negate? + loop-when-function + loop-unless-function) + ,form + ,(loop-construct-return nil)) +; #-For-NIL `(,pred ,form ,(loop-construct-return nil)) + #-For-NIL `(,(if negate? + loop-when-function + loop-unless-function) + ,form + ,(loop-construct-return nil)) +) + (push (loop-construct-return t) loop-after-epilogue))) + +;THEREIS expression +;If expression evaluates non-nil, return that value. +(defun loop-do-thereis () + (loop-emit-body `(,loop-when-function + (setq ,(loop-when-it-variable) + ,(loop-get-form 'thereis)) + ,(loop-construct-return loop-when-it-variable)))) + + +;;;; Hacks + +#+Meaningful-Type-Declarations + (declare (fixnum (loop-simplep-1 notype))) + +(defun si:loop-simplep (expr) + (if (null expr) 0 + (*catch 'si:loop-simplep + (let ((ans (si:loop-simplep-1 expr))) + #+Meaningful-Type-Declarations (declare (fixnum ans)) + (and (< ans 20.) ans))))) + +(defvar si:loop-simplep + (append '(> < greaterp lessp plusp minusp typep zerop + plus difference + - add1 sub1 1+ 1- + +$ -$ 1+$ 1-$ boole rot ash ldb equal atom + setq prog1 prog2 and or =) + #+(or Lispm NIL) '(aref ar-1 ar-2 ar-3) + #+Lispm '#.(and (loop-featurep Lispm) + (mapcar 'ascii '(#/ #/ #/))) + #+For-NIL '(1+& 1-& +& -& plusp& minusp& zerop& *& //& \& + si:xref char schar sbit svref sgaref) + )) + +(defun si:loop-simplep-1 (x) + (let ((z 0)) + #+Meaningful-Type-Declarations (declare (fixnum z)) + (cond ((loop-constantp x) 0) + ((atom x) 1) + ((eq (car x) 'cond) + (do ((cl (cdr x) (cdr cl))) ((null cl)) + (do ((f (car cl) (cdr f))) ((null f)) + (setq z (+ (si:loop-simplep-1 (car f)) z 1)))) + z) + ((symbolp (car x)) + (let ((fn (car x)) (tem ())) + (cond ((setq tem (get fn 'si:loop-simplep)) + (if (fixp tem) (setq z tem) + (setq z (funcall tem x) x ()))) + ((memq fn '(null not eq go return progn))) + (#+Run-on-PDP10 + (or (not (minusp (+internal-carcdrp fn))) + (eq fn 'cxr)) + #-Run-on-PDP10 (memq fn '(car cdr)) + (setq z 1)) + #-Run-on-PDP10 + ((memq fn '(caar cadr cdar cddr)) (setq z 2)) + #-Run-on-PDP10 + ((memq fn '(caaar caadr cadar caddr + cdaar cdadr cddar cdddr)) + (setq z 3)) + #-Run-on-PDP10 + ((memq fn '(caaaar caaadr caadar caaddr + cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr + cddaar cddadr cdddar cddddr)) + (setq z 4)) + ((memq fn si:loop-simplep) + (setq z 2)) + (#+(or Lispm For-PDP10 For-NIL) + (not (eq (setq tem (macroexpand-1 + x #+Common-Lisp-MACROs + loop-macro-environment)) + x)) + #+Franz (not (eq (setq tem (macroexpand x)) x)) + #+Multics + (setq tem (get (car x) 'macro)) + #+Multics (setq tem (funcall tem x)) + (setq z (si:loop-simplep-1 tem) x ())) + (t (*throw 'si:loop-simplep ()))) + (do ((l (cdr x) (cdr l))) ((null l)) + (setq z (+ (si:loop-simplep-1 (car l)) 1 z))) + z)) + (t (*throw 'si:loop-simplep ()))))) + + +;;;; The iteration driver +(defun loop-hack-iteration (entry) + (do ((last-entry entry) + (source loop-source-code loop-source-code) + (pre-step-tests ()) + (steps ()) + (post-step-tests ()) + (pseudo-steps ()) + (pre-loop-pre-step-tests ()) + (pre-loop-steps ()) + (pre-loop-post-step-tests ()) + (pre-loop-pseudo-steps ()) + (tem) (data) (foo) (bar)) + (()) + ; Note we collect endtests in reverse order, but steps in correct + ; order. LOOP-END-TESTIFY does the nreverse for us. + (setq tem (setq data (apply (cadr entry) (cddr entry)))) + (and (car tem) (push (car tem) pre-step-tests)) + (setq steps (nconc steps (loop-copylist* (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) post-step-tests)) + (setq pseudo-steps + (nconc pseudo-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (setq tem (cdr tem)) + (and (or loop-conditionals loop-emitted-body?) + (or tem pre-step-tests post-step-tests pseudo-steps) + (let ((cruft (list (car entry) (car source) + (cadr source) (caddr source)))) + (if loop-emitted-body? + (loop-simple-error + "Iteration is not allowed to follow body code" cruft) + (loop-simple-error + "Iteration starting inside of conditional in LOOP" + cruft)))) + (or tem (setq tem data)) + (and (car tem) (push (car tem) pre-loop-pre-step-tests)) + (setq pre-loop-steps + (nconc pre-loop-steps (loop-copylist* (car (setq tem (cdr tem)))))) + (and (car (setq tem (cdr tem))) (push (car tem) pre-loop-post-step-tests)) + (setq pre-loop-pseudo-steps + (nconc pre-loop-pseudo-steps (loop-copylist* (cadr tem)))) + (cond ((or (not (si:loop-tequal (car loop-source-code) 'and)) + (and loop-conditionals + (not (si:loop-tassoc (cadr loop-source-code) + loop-iteration-keyword-alist)))) + (setq foo (list (loop-end-testify pre-loop-pre-step-tests) + (loop-make-psetq pre-loop-steps) + (loop-end-testify pre-loop-post-step-tests) + (loop-make-setq pre-loop-pseudo-steps)) + bar (list (loop-end-testify pre-step-tests) + (loop-make-psetq steps) + (loop-end-testify post-step-tests) + (loop-make-setq pseudo-steps))) + (cond ((not loop-conditionals) + (setq loop-before-loop (nreconc foo loop-before-loop) + loop-after-body (nreconc bar loop-after-body))) + (t ((lambda (loop-conditionals) + (push (loop-make-conditionalization + (cons 'progn (delq () foo))) + loop-before-loop)) + (mapcar '(lambda (x) ;Copy parts that will get rplacd'ed + (cons (car x) + (mapcar '(lambda (x) (loop-copylist* x)) (cdr x)))) + loop-conditionals)) + (push (loop-make-conditionalization + (cons 'progn (delq () bar))) + loop-after-body))) + (loop-bind-block) + (return ()))) + (loop-pop-source) ; flush the "AND" + (setq entry (cond ((setq tem (si:loop-tassoc + (car loop-source-code) + loop-iteration-keyword-alist)) + (loop-pop-source) + (setq last-entry tem)) + (t last-entry))))) + + +;FOR variable keyword ..args.. +(defun loop-do-for () + (let ((var (loop-pop-source)) + (data-type? (loop-optional-type)) + (keyword (loop-pop-source)) + (first-arg nil) + (tem ())) + (setq first-arg (loop-get-form (list 'for var keyword))) + (or (setq tem (si:loop-tassoc keyword loop-for-keyword-alist)) + (loop-simple-error + "Unknown keyword in FOR or AS clause in LOOP" + (list 'for var keyword))) + (lexpr-funcall (cadr tem) var first-arg data-type? (cddr tem)))) + + +(defun loop-do-repeat () + (let ((var (loop-make-variable + (loop-gentemp 'loop-repeat-) + (loop-get-form 'repeat) 'fixnum))) + `((not (,(loop-typed-arith 'plusp 'fixnum) ,var)) + () () + (,var (,(loop-typed-arith 'sub1 'fixnum) ,var))))) + + +; Kludge the First +(defun loop-when-it-variable () + (or loop-when-it-variable + (setq loop-when-it-variable + (loop-make-variable (loop-gentemp 'loop-it-) () ())))) + + + +(defun loop-for-equals (var val data-type?) + (cond ((si:loop-tequal (car loop-source-code) 'then) + ;FOR var = first THEN next + (loop-pop-source) + (loop-make-iteration-variable var val data-type?) + `(() (,var ,(loop-get-form (list 'for var '= val 'then))) () () + () () () ())) + (t (loop-make-iteration-variable var () data-type?) + (let ((varval (list var val))) + (cond (loop-emitted-body? + (loop-emit-body (loop-make-setq varval)) + '(() () () ())) + (`(() ,varval () ()))))))) + +(defun loop-for-first (var val data-type?) + (or (si:loop-tequal (car loop-source-code) 'then) + (loop-simple-error "found where THEN expected in FOR ... FIRST" + (car loop-source-code))) + (loop-pop-source) + (loop-make-iteration-variable var () data-type?) + `(() (,var ,(loop-get-form (list 'for var 'first val 'then))) () () + () (,var ,val) () ())) + + +(defun loop-list-stepper (var val data-type? fn) + (let ((stepper (cond ((si:loop-tequal (car loop-source-code) 'by) + (loop-pop-source) + (loop-get-form (list 'for var + (if (eq fn 'car) 'in 'on) + val 'by))) + (t '(function cdr)))) + (var1 ()) (stepvar ()) (step ()) (et ()) (pseudo ())) + (setq step (if (or (atom stepper) + (not (memq (car stepper) '(quote function)))) + `(funcall ,(setq stepvar (loop-gentemp 'loop-fn-))) + (list (cadr stepper)))) + (cond ((and (atom var) + ;; (eq (car step) 'cdr) + (not fn)) + (setq var1 (loop-make-iteration-variable var val data-type?))) + (t (loop-make-iteration-variable var () data-type?) + (setq var1 (loop-make-variable + (loop-gentemp 'loop-list-) val ())) + (setq pseudo (list var (if fn (list fn var1) var1))))) + (rplacd (last step) (list var1)) + (and stepvar (loop-make-variable stepvar stepper ())) + (setq stepper (list var1 step) et `(null ,var1)) + (if (not pseudo) `(() ,stepper ,et () () () ,et ()) + (if (eq (car step) 'cdr) `(,et ,pseudo () ,stepper) + `((null (setq . ,stepper)) () () ,pseudo ,et () () ,pseudo))))) + + +(defun loop-for-arithmetic (var val data-type? kwd) + ; Args to loop-sequencer: + ; indexv indexv-type variable? vtype? sequencev? sequence-type + ; stephack? default-top? crap prep-phrases + (si:loop-sequencer + var (or data-type? 'fixnum) () () () () () () `(for ,var ,kwd ,val) + (cons (list kwd val) + (loop-gather-preps + '(from upfrom downfrom to upto downto above below by) + ())))) + + +(defun si:loop-named-variable (name) + (let ((tem (si:loop-tassoc name loop-named-variables))) + (cond ((null tem) (loop-gentemp)) + (t (setq loop-named-variables (delq tem loop-named-variables)) + (cdr tem))))) + +#+Run-in-Maclisp ;Gross me out +(and (status feature #+Multics Compiler #-Multics complr) + (*expr si:loop-named-variable)) + + +; Note: path functions are allowed to use loop-make-variable, hack +; the prologue, etc. +(defun loop-for-being (var val data-type?) + ; FOR var BEING something ... - var = VAR, something = VAL. + ; If what passes syntactically for a pathname isn't, then + ; we trap to the DEFAULT-LOOP-PATH path; the expression which looked like + ; a path is given as an argument to the IN preposition. Thus, + ; by default, FOR var BEING EACH expr OF expr-2 + ; ==> FOR var BEING DEFAULT-LOOP-PATH IN expr OF expr-2. + (let ((tem) (inclusive?) (ipps) (each?) (attachment)) + (if (or (si:loop-tequal val 'each) (si:loop-tequal val 'the)) + (setq each? 't val (car loop-source-code)) + (push val loop-source-code)) + (cond ((and (setq tem (si:loop-tassoc val loop-path-keyword-alist)) + (or each? (not (si:loop-tequal (cadr loop-source-code) + 'and)))) + ;; FOR var BEING {each} path {prep expr}..., but NOT + ;; FOR var BEING var-which-looks-like-path AND {ITS} ... + (loop-pop-source)) + (t (setq val (loop-get-form (list 'for var 'being))) + (cond ((si:loop-tequal (car loop-source-code) 'and) + ;; FOR var BEING value AND ITS path-or-ar + (or (null each?) + (loop-simple-error + "Malformed BEING EACH clause in LOOP" var)) + (setq ipps `((of ,val)) inclusive? 't) + (loop-pop-source) + (or (si:loop-tmember (setq tem (loop-pop-source)) + '(its his her their each)) + (loop-simple-error + "found where ITS or EACH expected in LOOP path" + tem)) + (if (setq tem (si:loop-tassoc + (car loop-source-code) + loop-path-keyword-alist)) + (loop-pop-source) + (push (setq attachment + `(in ,(loop-get-form + `(for ,var being /././. in)))) + ipps))) + ((not (setq tem (si:loop-tassoc + (car loop-source-code) + loop-path-keyword-alist))) + ; FOR var BEING {each} a-r ... + (setq ipps (list (setq attachment (list 'in val))))) + (t ; FOR var BEING {each} pathname ... + ; Here, VAL should be just PATHNAME. + (loop-pop-source))))) + (cond ((not (null tem))) + ((not (setq tem (si:loop-tassoc 'default-loop-path + loop-path-keyword-alist))) + (loop-simple-error "Undefined LOOP iteration path" + (cadr attachment)))) + (setq tem (funcall (cadr tem) (car tem) var data-type? + (nreconc ipps (loop-gather-preps (caddr tem) 't)) + inclusive? (caddr tem) (cdddr tem))) + (and loop-named-variables + (loop-simple-error "unused USING variables" loop-named-variables)) + ; For error continuability (if there is any): + (setq loop-named-variables ()) + ;; TEM is now (bindings prologue-forms . stuff-to-pass-back) + (do ((l (car tem) (cdr l)) (x)) ((null l)) + (if (atom (setq x (car l))) + (loop-make-iteration-variable x () ()) + (loop-make-iteration-variable (car x) (cadr x) (caddr x)))) + (setq loop-prologue (nconc (reverse (cadr tem)) loop-prologue)) + (cddr tem))) + + +(defun loop-gather-preps (preps-allowed crockp) + (do ((token (car loop-source-code) (car loop-source-code)) (preps ())) + (()) + (cond ((si:loop-tmember token preps-allowed) + (push (list (loop-pop-source) + (loop-get-form `(for /././. being /././. ,token))) + preps)) + ((si:loop-tequal token 'using) + (loop-pop-source) + (or crockp (loop-simple-error + "USING used in illegal context" + (list 'using (car loop-source-code)))) + (do ((z (car loop-source-code) (car loop-source-code)) (tem)) + ((atom z)) + (and (or (atom (cdr z)) + (not (null (cddr z))) + (not (symbolp (car z))) + (and (cadr z) (not (symbolp (cadr z))))) + (loop-simple-error + "bad variable pair in path USING phrase" z)) + (cond ((not (null (cadr z))) + (and (setq tem (si:loop-tassoc + (car z) loop-named-variables)) + (loop-simple-error + "Duplicated var substitition in USING phrase" + (list tem z))) + (push (cons (car z) (cadr z)) loop-named-variables))) + (loop-pop-source))) + (t (return (nreverse preps)))))) + +(defun loop-add-path (name data) + (setq loop-path-keyword-alist + (cons (cons name data) + ; Don't change this to use DELASSQ in PDP10, the lsubr + ; calling sequence makes that lose. + (delq (si:loop-tassoc name loop-path-keyword-alist) + loop-path-keyword-alist))) + ()) + +#+Run-on-PDP10 +(declare ; Suck my obarray... + (own-symbol define-loop-path define-loop-sequence-path)) + +(defmacro define-loop-path (names &rest cruft) + "(DEFINE-LOOP-PATH NAMES PATH-FUNCTION LIST-OF-ALLOWABLE-PREPOSITIONS +DATUM-1 DATUM-2 ...) +Defines PATH-FUNCTION to be the handler for the path(s) NAMES, which may +be either a symbol or a list of symbols. LIST-OF-ALLOWABLE-PREPOSITIONS +contains a list of prepositions allowed in NAMES. DATUM-i are optional; +they are passed on to PATH-FUNCTION as a list." + (setq names (if (atom names) (list names) names)) + #-For-Maclisp + (let ((forms (mapcar #'(lambda (name) `(loop-add-path ',name ',cruft)) + names))) + `(eval-when (eval load compile) + #+For-NIL (flush-macromemos 'loop ()) + ,@forms)) + #+For-Maclisp + (subst (do ((l)) ((null names) l) + (setq l (cons `(setq loop-path-keyword-alist + (cons '(,(car names) . ,cruft) + (delq (assq ',(car names) + loop-path-keyword-alist) + loop-path-keyword-alist))) + l) + names (cdr names))) + 'progn + '(eval-when (eval load compile) + #-For-PDP10 (or (boundp 'loop-path-keyword-alist) + (setq loop-path-keyword-alist ())) + #+For-PDP10 (and (or (boundp 'loop-path-keyword-alist) + (setq loop-path-keyword-alist ())) + (flush-macromemos 'loop ())) + . progn))) + + +(defun si:loop-sequencer (indexv indexv-type + variable? vtype? + sequencev? sequence-type? + stephack? default-top? + crap prep-phrases) + (let ((endform) (sequencep) (test) + (step ; Gross me out! + (add1 (or (loop-typed-init indexv-type) 0))) + (dir) (inclusive-iteration?) (start-given?) (limit-given?)) + (and variable? (loop-make-iteration-variable variable? () vtype?)) + (do ((l prep-phrases (cdr l)) (prep) (form) (odir)) ((null l)) + (setq prep (caar l) form (cadar l)) + (cond ((si:loop-tmember prep '(of in)) + (and sequencep (loop-simple-error + "Sequence duplicated in LOOP path" + (list variable? (car l)))) + (setq sequencep 't) + (loop-make-variable sequencev? form sequence-type?)) + ((si:loop-tmember prep '(from downfrom upfrom)) + (and start-given? + (loop-simple-error + "Iteration start redundantly specified in LOOP sequencing" + (append crap l))) + (setq start-given? 't) + (cond ((si:loop-tequal prep 'downfrom) (setq dir 'down)) + ((si:loop-tequal prep 'upfrom) (setq dir 'up))) + (loop-make-iteration-variable indexv form indexv-type)) + ((cond ((si:loop-tequal prep 'upto) + (setq inclusive-iteration? (setq dir 'up))) + ((si:loop-tequal prep 'to) + (setq inclusive-iteration? 't)) + ((si:loop-tequal prep 'downto) + (setq inclusive-iteration? (setq dir 'down))) + ((si:loop-tequal prep 'above) (setq dir 'down)) + ((si:loop-tequal prep 'below) (setq dir 'up))) + (and limit-given? + (loop-simple-error + "Endtest redundantly specified in LOOP sequencing path" + (append crap l))) + (setq limit-given? 't) + (setq endform (loop-maybe-bind-form form indexv-type))) + ((si:loop-tequal prep 'by) + (setq step (if (loop-constantp form) form + (loop-make-variable + (loop-gentemp 'loop-step-by-) + form 'fixnum)))) + (t ; This is a fatal internal error... + (loop-simple-error "Illegal prep in sequence path" + (append crap l)))) + (and odir dir (not (eq dir odir)) + (loop-simple-error + "Conflicting stepping directions in LOOP sequencing path" + (append crap l))) + (setq odir dir)) + (and sequencev? (not sequencep) + (loop-simple-error "Missing OF phrase in sequence path" crap)) + ; Now fill in the defaults. + (setq step (list indexv step)) + (cond ((memq dir '(() up)) + (or start-given? + (loop-make-iteration-variable indexv 0 indexv-type)) + (and (or limit-given? + (cond (default-top? + (loop-make-variable + (setq endform (loop-gentemp + 'loop-seq-limit-)) + () indexv-type) + (push `(setq ,endform ,default-top?) + loop-prologue)))) + (setq test (if inclusive-iteration? '(greaterp . args) + '(not (lessp . args))))) + (push 'plus step)) + (t (cond ((not start-given?) + (or default-top? + (loop-simple-error + "Don't know where to start stepping" + (append crap prep-phrases))) + (loop-make-iteration-variable indexv 0 indexv-type) + (push `(setq ,indexv + (,(loop-typed-arith 'sub1 indexv-type) + ,default-top?)) + loop-prologue))) + (cond ((and default-top? (not endform)) + (setq endform (loop-typed-init indexv-type) + inclusive-iteration? 't))) + (and (not (null endform)) + (setq test (if inclusive-iteration? '(lessp . args) + '(not (greaterp . args))))) + (push 'difference step))) + (and #+(or Lispm (and For-NIL (not Run-in-Maclisp))) + (and (numberp (caddr step)) (= (caddr step) 1)) ;Generic arith + #-(or Lispm (and For-NIL (not Run-in-Maclisp))) + (member (caddr step) + #+Loop-Small-Floatp + '(1 1.0 #.(and (loop-featurep Loop-Small-Floatp) + (small-float 1))) + #-Loop-Small-Floatp '(1 1.0)) + (rplacd (cdr (rplaca step (if (eq (car step) 'plus) 'add1 'sub1))) + ())) + (rplaca step (loop-typed-arith (car step) indexv-type)) + (setq step (list indexv step)) + (setq test (loop-typed-arith test indexv-type)) + (setq test (subst (list indexv endform) 'args test)) + (and stephack? (setq stephack? `(,variable? ,stephack?))) + `(() ,step ,test ,stephack? + () () ,test ,stephack?))) + + +; Although this function is no longer documented, the "SI:" is needed +; because compiled files may reference it that way (via +; DEFINE-LOOP-SEQUENCE-PATH). +(defun si:loop-sequence-elements-path (path variable data-type + prep-phrases inclusive? + allowed-preps data) + allowed-preps ; unused + (let ((indexv (si:loop-named-variable 'index)) + (sequencev (si:loop-named-variable 'sequence)) + (fetchfun ()) (sizefun ()) (type ()) (default-var-type ()) + (crap `(for ,variable being the ,path))) + (cond ((not (null inclusive?)) + (rplacd (cddr crap) `(,(cadar prep-phrases) and its ,path)) + (loop-simple-error "Can't step sequence inclusively" crap))) + (setq fetchfun (car data) + sizefun (car (setq data (cdr data))) + type (car (setq data (cdr data))) + default-var-type (cadr data)) + (list* () () ; dummy bindings and prologue + (si:loop-sequencer + indexv 'fixnum + variable (or data-type default-var-type) + sequencev type + `(,fetchfun ,sequencev ,indexv) `(,sizefun ,sequencev) + crap prep-phrases)))) + + +#+Run-on-PDP10 +(defun (define-loop-sequence-path macro) (x) + `(define-loop-path ,(cadr x) si:loop-sequence-elements-path + (of in from downfrom to downto below above by) + . ,(cddr x))) + +#-Run-on-PDP10 +(defmacro define-loop-sequence-path (path-name-or-names fetchfun sizefun + &optional sequence-type element-type) + "Defines a sequence iiteration path. PATH-NAME-OR-NAMES is either an +atomic path name or a list of path names. FETCHFUN is a function of +two arguments, the sequence and the index of the item to be fetched. +/(Indexing is assumed to be zero-origined. SIZEFUN is a function of +one argument, the sequence; it should return the number of elements in +the sequence. SEQUENCE-TYPE is the name of the data-type of the +sequence, and ELEMENT-TYPE is the name of the data-type of the elements +of the sequence." + `(define-loop-path ,path-name-or-names + si:loop-sequence-elements-path + (of in from downfrom to downto below above by) + ,fetchfun ,sizefun ,sequence-type ,element-type)) + + +;;;; NIL interned-symbols path + +#+For-NIL +(progn 'compile +(defun loop-interned-symbols-path (path variable data-type prep-phrases + inclusive? allowed-preps data + &aux statev1 statev2 statev3 + (localp (car data))) + allowed-preps ; unused + (and inclusive? (loop-simple-error + "INTERNED-SYMBOLS path doesn't work inclusively" + variable)) + (and (not (null prep-phrases)) + (or (cdr prep-phrases) + (not (si:loop-tmember (caar prep-phrases) '(in of)))) + (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A" + path variable prep-phrases)) + (loop-make-variable variable () data-type) + (loop-make-variable + (setq statev1 (loop-gentemp)) + `(loop-find-package ,@(and prep-phrases `(,(cadar prep-phrases)))) + ()) + (loop-make-variable (setq statev2 (loop-gentemp)) () ()) + (loop-make-variable (setq statev3 (loop-gentemp)) () ()) + (push `(multiple-value (,statev1 ,statev2 ,statev3) + (loop-initialize-mapatoms-state ,statev1 ',localp)) + loop-prologue) + `(() () (multiple-value (() ,statev1 ,statev2 ,statev3) + (,(if localp 'loop-test-and-step-mapatoms-local + 'loop-test-and-step-mapatoms) + ,statev1 ,statev2 ,statev3)) + (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3)) () ())) + +(defun loop-find-package (&optional (pkg () pkgp)) + #+Run-in-Maclisp + (if pkgp pkg obarray) + #-Run-in-Maclisp + (if pkgp (pkg-find-package pkg) package)) + +(defun loop-find-package-translate (form) + ; Note that we can only be compiling for nil-nil, so we only need + ; to consider that. The run-in-maclisp conditionals in the functions + ; are for the benefit of running interpreted code. + (values (if (null (cdr form)) 'package `(pkg-find-package ,(cadr form))) 't)) + +(putprop 'loop-find-package + '(loop-find-package-translate) + 'source-trans) + +#-Run-in-Maclisp +(defun loop-initialize-mapatoms-state (pkg localp) + (let* ((symtab (si:package-symbol-table pkg)) + (len (simple-vector-length symtab))) + (values pkg symtab len))) + +#+Run-in-Maclisp +(defun loop-initialize-mapatoms-state (ob ()) + (values ob (ncons nil) 511.)) + +#-Run-in-Maclisp +(defun loop-test-and-step-mapatoms (pkg symtab index &aux val) + (prog () + lp (cond ((<& (setq index (1-& index)) 0) + (unless (setq pkg (si:package-super-package pkg)) + (return (setq val t))) + (setq symtab (si:package-symbol-table pkg)) + (setq index (simple-vector-length symtab)) + (go lp)) + ((symbolp (svref symtab index)) (return nil)) + (t (go lp)))) + (values val pkg symtab index)) + +#+Run-in-Maclisp +(defun loop-test-and-step-mapatoms (ob list index) + (loop-test-and-step-mapatoms-local ob list index)) + +#-Run-in-Maclisp +(defun loop-test-and-step-mapatoms-local (pkg symtab index &aux val) + (prog () + lp (cond ((<& (setq index (1-& index)) 0) (return (setq val 't))) + ((symbolp (svref symtab index)) (return nil)) + (t (go lp)))) + (values val pkg symtab index)) + +#+Run-in-Maclisp +(defun loop-test-and-step-mapatoms-local (ob list index &aux val) + (declare (fixnum index)) + (prog () + lp (cond ((not (null (cdr list))) + (rplaca list (cadr list)) + (rplacd list (cddr list)) + (return ())) + ((minusp (setq index (1- index))) (return (setq val 't))) + (t ; If this is going to run in multics maclisp also the + ; arraycall should be hacked to have type `obarray'. + (rplacd list (arraycall t ob index)) + (go lp)))) + (values val ob list index)) + +#-Run-in-Maclisp +(defun loop-get-mapatoms-symbol (pkg symtab index) + (declare (ignore pkg)) + (svref symtab index)) + +#+Run-in-Maclisp +(defun loop-get-mapatoms-symbol (ob list index) + (declare (ignore ob index)) + (car list)) + +(and #+Run-in-Maclisp (status feature complr) + (*expr loop-get-mapatoms-symbol + loop-initialize-mapatoms-state + loop-test-and-step-mapatoms + loop-test-and-step-mapatoms-local)) +) + + +;;;; Maclisp interned-symbols path + +#+For-Maclisp +(defun loop-interned-symbols-path (path variable data-type prep-phrases + inclusive? allowed-preps data + &aux indexv listv ob) + allowed-preps data ; unused vars + (and inclusive? (loop-simple-error + "INTERNED-SYMBOLS path doesn't work inclusively" + variable)) + (and (not (null prep-phrases)) + (or (cdr prep-phrases) + (not (si:loop-tmember (caar prep-phrases) '(in of)))) + (loop-simple-error + "Illegal prep phrase(s) in INTERNED-SYMBOLS LOOP path" + (list* variable 'being path prep-phrases))) + (loop-make-variable variable () data-type) + (loop-make-variable + (setq ob (gensym)) (if prep-phrases (cadar prep-phrases) 'obarray) ()) + ; Multics lisp does not store single-char-obs in the obarray buckets. + ; Thus, we need to iterate over the portion of the obarray + ; containing them also. (511. = (ascii 0)) + (loop-make-variable + (setq indexv (loop-gentemp)) #+Multics 639. #-Multics 511. 'fixnum) + (loop-make-variable (setq listv (loop-gentemp)) () ()) + `(() () + (and #-Multics (null ,listv) + #+Multics (or (> ,indexv 510.) (null ,listv)) + (prog () + lp (cond ((minusp (setq ,indexv (1- ,indexv))) + ,(loop-construct-return t)) + ((setq ,listv (arraycall ; The following is the kind of + ; gratuity that pisses me off: + #+Multics obarray #-Multics t + ,ob ,indexv)) + ,(loop-construct-return nil)) + ((go lp))))) + (,variable + #+Multics (cond ((> ,indexv 510.) ,listv) + (t (prog2 () (car ,listv) (setq ,listv (cdr ,listv))))) + #-Multics (car ,listv)) + () + #+Multics () #-Multics (,listv (cdr ,listv)))) + + + +;;;; MIT/LMI interned-symbols path + +#+(and Lispm MIT) +(progn 'compile + + (defun loop-interned-symbols-path (path variable data-type prep-phrases + inclusive? allowed-preps data + &aux statev1 statev2 statev3 statev4 + (localp (car data))) + path data-type allowed-preps ; unused vars + (and inclusive? (loop-simple-error + "INTERNED-SYMBOLS path doesn't work inclusively" + variable)) + (and (not (null prep-phrases)) + (or (cdr prep-phrases) + (not (si:loop-tmember (caar prep-phrases) '(in of)))) + (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A" + path variable prep-phrases)) + (loop-make-variable variable () data-type) + (loop-make-variable + (setq statev1 (loop-gentemp)) + (if prep-phrases `(pkg-find-package ,(cadar prep-phrases)) 'package) + ()) + (loop-make-variable (setq statev2 (loop-gentemp)) () ()) + (loop-make-variable (setq statev3 (loop-gentemp)) () ()) + (loop-make-variable (setq statev4 (loop-gentemp)) () ()) + (push `(multiple-value (,statev1 ,statev2 ,statev3 ,statev4) + (loop-initialize-mapatoms-state ,statev1 ,localp)) + loop-prologue) + `(() () (multiple-value (nil ,statev1 ,statev2 ,statev3 ,statev4) + (loop-test-and-step-mapatoms + ,statev1 ,statev2 ,statev3 ,statev4)) + (,variable ,statev2) + () ())) + + (defun loop-initialize-mapatoms-state (pkg localp) + ; Return the initial values of the four state variables. + ; This scheme uses them to be: + ; (1) Index into the package (decremented as we go) + ; (2) Temporary (to hold the symbol) + ; (3) the package + ; (4) a list of other packages to consider. + (prog () + (return (dont-optimize (pkg-number-of-slots pkg)) + () pkg + (and localp (package-use-list pkg))))) + + (defun loop-test-and-step-mapatoms (index temp pkg other-packages) + temp ; ignored + (prog () + lp (cond ((< (setq index (1- index)) 0) + (cond ((setq pkg (car other-packages)) + (pop other-packages) + (setq index (dont-optimize (pkg-number-of-slots pkg))) + (go lp)) + (t (return t)))) + ((dont-optimize + (pkg-code-valid-p + (dont-optimize (pkg-slot-code pkg index)))) + (return nil index + (dont-optimize (pkg-slot-symbol pkg index)) + pkg other-packages)) + (t (go lp))))) + + ) + + +;;;; Symbolics interned-symbols path + +#+(and Lispm Symbolics) +(progn 'compile + + (defun loop-interned-symbols-path (path variable data-type prep-phrases + inclusive? allowed-preps data + &aux statev1 statev2 statev3 + (localp (car data))) + path data-type allowed-preps ; unused vars + (and inclusive? (loop-simple-error + "INTERNED-SYMBOLS path doesn't work inclusively" + variable)) + (and (not (null prep-phrases)) + (or (cdr prep-phrases) + (not (si:loop-tmember (caar prep-phrases) '(in of)))) + (ferror () "Illegal prep phrase(s) in ~A path of ~A - ~A" + path variable prep-phrases)) + (loop-make-variable variable () data-type) + (loop-make-variable + (setq statev1 (loop-gentemp)) + (if prep-phrases `(pkg-find-package ,(cadar prep-phrases)) 'package) + ()) + (loop-make-variable (setq statev2 (loop-gentemp)) () ()) + (loop-make-variable (setq statev3 (loop-gentemp)) () ()) + (push `(multiple-value (,statev1 ,statev2 ,statev3) + (loop-initialize-mapatoms-state ,statev1 ,localp)) + loop-prologue) + `(() () (multiple-value (nil ,statev1 ,statev2 ,statev3) + (,(if localp 'loop-test-and-step-mapatoms-local + 'loop-test-and-step-mapatoms) + ,statev1 ,statev2 ,statev3)) + (,variable (loop-get-mapatoms-symbol ,statev1 ,statev2 ,statev3)) + () ())) + +;The functions loop-initialize-mapatoms-state, loop-test-and-step-mapatoms, +; and loop-test-and-step-mapatoms-local are all provided by the package +; system. + + (defsubst loop-get-mapatoms-symbol (index temp pkg) + index pkg ; ignored + temp) + ) + +;;;; LOOP iteration path for hash tables (NIL & Lispm) + +#+(or Lispm NIL) +(progn 'compile + +#+NIL +;Not yet defined in NIL. Will it ever be? +(eval-when (eval compile) + (defmacro selector (item pred &body clauses &aux (var (gensym))) + `(let ((,var ,item)) + (cond ,@(loop for (k . consequents) in clauses + collect + (cons (cond ((memq k '(t otherwise :otherwise)) t) + ((atom k) `(,pred ,var ,k)) + (t (cons 'or (mapcar #'(lambda (x) + `(,pred ,var ,x)) + k)))) + consequents)))))) + + +(define-loop-path hash-elements loop-hash-elements-path (of with-key)) + + +#-(and Lispm MIT) +;The loop path for NIL and symbolics Lispm systems. +(defun loop-hash-elements-path (path variable data-type prep-phrases + inclusive? allowed-preps data + &aux (key-var (loop-gentemp 'loop-hash-key-)) + (hash-tbl nil)) + path data-type allowed-preps data ;ignored + ;; Now parse the prep phrases + (loop for (prep expr) in prep-phrases + do (selector prep loop-tequal + (('of) (setq hash-tbl expr)) + (('with-key) (setq key-var expr)) + (otherwise + (ferror "~S is not a known preposition for the HASH-ELEMENTS path" prep)))) + (if (null hash-tbl) (ferror "The hash table must be specified (the OF clause was missing)")) + (if inclusive? (ferror "Inclusive stepping is not supported by the HASH-ELEMENTS path.")) + (push '(inhibit-gc-flips) loop-wrappers) + (let* ((step-var (loop-gentemp 'loop-hash-step-)) + (bindings `((,step-var) + (,key-var) + (,variable))) + (prologue `()) + (iterspec `(() + (,variable (progn (multiple-value (,step-var ,key-var ,variable) + (send ,hash-tbl ':next-element ,step-var)) + ,variable)) + (null ,step-var) + ()))) + (list* bindings prologue iterspec))) + + +#+(and Lispm MIT) +;MIT version of above. +(defun loop-hash-elements-path (ignore variable ignore prep-phrases + inclusive? ignore ignore) + (if inclusive? + (ferror nil "Inclusive stepping not supported in HASH-ELEMENTS path for ~S." + variable)) + (unless (loop-tassoc 'of prep-phrases) + (ferror nil "No OF phrase in HASH-ELEMENTS path for ~S." variable)) + (let (bindings prologue steps post-endtest pseudo-steps + (blen-var (loop-gentemp 'loop-hash-block-len-)) + (ht-var (loop-gentemp 'loop-hash-table-)) + (i-var (loop-gentemp)) + (len-var (loop-gentemp 'loop-hash-len-)) + (tem (loop-gentemp)) + (key-var (or (cadr (loop-tassoc 'with-key prep-phrases)) + (loop-gentemp 'loop-hash-key-))) + (offset-var (loop-gentemp 'loop-hash-offset-))) + (setq bindings `((,ht-var (send ,(cadr (loop-tassoc 'of prep-phrases)) ':hash-array)) + (,blen-var nil) (,offset-var nil) (,variable nil) + (,i-var nil) (,key-var nil) (,len-var nil)) + prologue `((setq ,blen-var + (hash-table-block-length ,ht-var)) + (setq ,i-var (- ,blen-var)) + (setq ,offset-var (if (hash-table-hash-function ,ht-var) 1 0)) + (setq ,len-var (array-length ,ht-var))) + steps `(,i-var + (do ((,tem (+ ,blen-var ,i-var) (+ ,blen-var ,tem))) + ((or ( ,tem ,len-var) + ( (%p-data-type (aloc ,ht-var ,tem)) dtp-null)) + ,tem))) + post-endtest `( ,i-var ,len-var) + pseudo-steps `(,key-var (aref ,ht-var (+ ,i-var ,offset-var)) + ,variable (aref ,ht-var (+ ,i-var ,offset-var 1)))) + (list bindings prologue nil steps post-endtest pseudo-steps))) + +) ;progn 'compile + + +;;;; Setup stuff + + +; We don't want these defined in the compilation environment because +; the appropriate environment hasn't been set up. So, we just bootstrap +; them up. +(mapc '(lambda (x) + (mapc '(lambda (y) + (setq loop-path-keyword-alist + (cons (cons y (cdr x)) + (delq (si:loop-tassoc + y loop-path-keyword-alist) + loop-path-keyword-alist)))) + (car x))) + '( + #+(or For-NIL For-Maclisp Lispm) + ((interned-symbols interned-symbol) + loop-interned-symbols-path (in)) + #+(or For-NIL Lispm) + ((local-interned-symbols local-interned-symbol) + loop-interned-symbols-path (in) t) + )) + +#-Multics ; none defined yet +(mapc #'(lambda (x) + (mapc #'(lambda (y) + (setq loop-path-keyword-alist + (cons `(,y si:loop-sequence-elements-path + (of in from downfrom to downto + below above by) + . ,(cdr x)) + (delq (si:loop-tassoc + y loop-path-keyword-alist) + loop-path-keyword-alist)))) + (car x))) + '(#+Lispm + ((array-element array-elements) ar-1-force array-active-length) + #+(and For-NIL (not Run-in-Maclisp)) + ((array-element array-elements) aref-rmoi array-total-size array) + #+(or Lispm (and For-NIL (not Run-in-Maclisp))) + ((element elements) elt length sequence) + ;The following should be done by using ELEMENTS and type dcls... + #+(and For-NIL (not Run-in-Maclisp)) + ((vector-element vector-elements) aref vector-length vector) + #+(and For-NIL (not Run-in-Maclisp)) + ((simple-vector-element simple-vector-elements + simple-general-vector-element simple-general-vector-elements) + svref simple-vector-length simple-vector) + #+(and For-NIL (not Run-in-Maclisp)) + ((bits bit bit-vector-element bit-vector-elements) + bit bit-vector-length bit-vector bit) + #+(and For-NIL (not Run-in-Maclisp)) + ((simple-bit-vector-element simple-bit-vector-elements) + sbit simple-bit-vector-length simple-bit-vector bit) + #+(and For-NIL (not Run-in-Maclisp)) + ((character characters string-element string-elements) + char string-length string string-char) + #+(and Lispm MIT) + ((character characters string-element string-elements) + char length string string-char) + #+(and For-NIL (not Run-in-Maclisp)) + ((simple-string-element simple-string-elements) + schar simple-string-length simple-string string-char) + ) + ) + +;Sigh. (c.f. loop-featurep, note macro-expansion lossage.) +; Note that we end up doing both in the PDP10 NIL version, in which they +; are different. +#+(or (not For-NIL) Run-in-Maclisp) + (or (status feature loop) (sstatus feature loop)) +#+For-NIL + (set-feature 'loop 'local) \ No newline at end of file diff --git a/src/lspsrc/cerror.47 b/src/lspsrc/cerror.47 new file mode 100755 index 00000000..0fbfaaef --- /dev/null +++ b/src/lspsrc/cerror.47 @@ -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))) + diff --git a/src/lspsrc/descri.4 b/src/lspsrc/descri.4 new file mode 100755 index 00000000..12813cb9 --- /dev/null +++ b/src/lspsrc/descri.4 @@ -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)) + () ) diff --git a/src/lspsrc/dumpar.8 b/src/lspsrc/dumpar.8 new file mode 100755 index 00000000..bdfcc14f --- /dev/null +++ b/src/lspsrc/dumpar.8 @@ -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))) + diff --git a/src/lspsrc/edit.37 b/src/lspsrc/edit.37 new file mode 100755 index 00000000..bce4d9d1 --- /dev/null +++ b/src/lspsrc/edit.37 @@ -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 ( ) - , . +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+ + 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 diff --git a/src/lspsrc/extbas.39 b/src/lspsrc/extbas.39 new file mode 100755 index 00000000..c71c4ad0 --- /dev/null +++ b/src/lspsrc/extbas.39 @@ -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)))))) diff --git a/src/lspsrc/extend.292 b/src/lspsrc/extend.292 new file mode 100755 index 00000000..df2d7c66 --- /dev/null +++ b/src/lspsrc/extend.292 @@ -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)))) diff --git a/src/lspsrc/extmac.191 b/src/lspsrc/extmac.191 new file mode 100755 index 00000000..a8c1c537 --- /dev/null +++ b/src/lspsrc/extmac.191 @@ -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 . ). + 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) + + diff --git a/src/lspsrc/extsfa.8 b/src/lspsrc/extsfa.8 new file mode 100755 index 00000000..5a8a9ebc --- /dev/null +++ b/src/lspsrc/extsfa.8 @@ -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) + diff --git a/src/lspsrc/extstr.97 b/src/lspsrc/extstr.97 new file mode 100644 index 00000000..d5e6d396 --- /dev/null +++ b/src/lspsrc/extstr.97 @@ -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)) + diff --git a/src/lspsrc/grind.422 b/src/lspsrc/grind.422 new file mode 100644 index 00000000..5e2156d5 --- /dev/null +++ b/src/lspsrc/grind.422 @@ -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 + +(sstatus feature grind) diff --git a/src/lspsrc/grinde.462 b/src/lspsrc/grinde.462 new file mode 100644 index 00000000..7d11d714 --- /dev/null +++ b/src/lspsrc/grinde.462 @@ -0,0 +1,1520 @@ +;;; GFN -*-LISP-*- +;;; ************************************************************** +;;; ***** Maclisp ****** S-expression formatter (grindef) ******** +;;; ************************************************************** +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** this is a read-only file! (all writes reserved) ******* +;;; ************************************************************** +;;; +;;; 04/06/81 kmp - renamed PREDICT to GPREDICT to avoid name conflicts with +;;; other systems. for compatibility, i do a +;;; (DEFPROP PREDICT GPREDICT EXPR) iff PREDICT is not +;;; fboundp at load time. this defprop should go away sometime +;;; after people have made the changeover. +;;; 01/29/81 jonl - flushed (STATUS FEATURE MACAID) and NIL --> () +;;; added special declaration for GRIND-MACROEXPANDED +;;; 04/15/80 kmp - made GRLINEL use the value of GRLINEL variable if it is +;;; bound rather than guessing about a LINEL by looking at +;;; outfiles. It is defaultly UNBOUND. +;;; 04/13/80 rwk - made SETF grind like SETQ. Added OWN-SYMBOL's for system +;;; funs. Converted THROW's to *THROWs, CATCH's to *CATCHs. +;;; Tag in both cases of () +;;; 04/02/80 rees - introduced GATOMP in an attempt to make handling of +;;; hunks more consistent. Complete crockery. +;;; Also added variable GRIND*RSET so I can debug the +;;; damn thing. +;;; 02/28/80 kmp - removed buggy COND for re-examination, too. sigh. +;;; 02/27/80 kmp - removed LET and CASEQ buggy grindfn properties until +;;; they can be looked into in more detail. They don't +;;; currently do the right thing as GLS points out. +;;; 02/24/80 kmp - added grind properties for DO and CASEQ. Fixed DEF-FORM +;;; to handle DEFMACRO and DEFUN& optimally. +;;; 02/18/80 kmp - nreversed this history to put new entries at the top +;;; fixed. Made EVAL-WHEN grind right. +;;; 02/14/80 kmp - flushed some old, unreachable code from several points, +;;; clearly marked. Made LET/LAMBDA grind right. +;;; 02/11/80 kmp - hunk pretty-printing supported. depends on the variable +;;; hunkp being non-nil and the variable hunksprin1 being +;;; set to a pretty-printer. default printers provided. +;;; if either variable is NIL, hunks are sprinter'd like lists. +;;; fixed a probably non-existent bug in the sprintering of +;;; non-atomic atoms in the cdr of a cons. +;;; 02/04/80 jonl - lambda-bind *RSET for "interior" calls, to achieve speed. +;;; Installed use of HERALD and DEFSIMPLEMAC (in MULTICS +;;; case) "require"ing loading MACAID +;;; 11/28/79 alan - fixed GFLATSIZE1 (see kmp 6/18/79) to only look at +;;; property lists of symbols (e.g. not lists!) +;;; 11/15/79 kmp - fixed SPRIN1 to take a file object as second arg, augmenting +;;; addition to former ability to take a list of files... +;;; 11/8/79 rees - minor bug fixes, e. g. ",." flatsizing, 2nd SPRIN1 +;;; arg, VERSION property and (LISP) device modernization +;;; 09/27/79 rees - Changed name of "FORM" to "GRINDFORM" +;;; Added function SPRIN1 for prettyprinting PRIN1 +;;; 09/25/79 jonl - Changed name of "FILL" to "GRINDFILL" +;;; Installed some usage of # +;;; 06/19/79 kmp - Fixed bug that non-null end of list in 'block'-type +;;; special forms were blindly CAR'ing and CDR'ing +;;; the atom. +;;; 06/18/79 kmp - Added in GFLATSIZE1 and ability to check for a +;;; GRINDFLATSIZE property on CAR's of forms. +;;; 05/24/79 jonl - Add some special grindmacro functions for backquote +;;; and defmacro stuff. +;;; 05/03/79 kmp - lambda-bind ERRSET when loading init file so people +;;; with ERRSET handlers don't get breakpoints at what +;;; is really a non-error. (version 421) +;;; 03/30/79 jonl - flush CNVR stuff, put in a modern loading-message-print, +;;; and a modern-style init file finder. +;;; 01/09/79 jonl - flush "niop/|", since only newio is available. Fix up +;;; autoload property for GRILAP +;;; 11/01/78 jonl - print loading message on MSGFILES instead of OUTFILES +;;; don't GRINDEF is atomic arg is not a SYMBOL +;;; 09/15/78 {hic?} - let "*" be returned instead of (ascii 0) +;;; 07/12/78 jonl - Fix up usages of LINEL by creating function GRLINEL, +;;; and install macros for POPL and REMSEMI-TAC +;;; 05/25/78 jonl - Had GRINDEF and SPRINTER lambda-bind variable LINEL, and +;;; removed all references to CONNIVER and PLANNER stuff. +;;; Flush "SGPLOSES" and NOARGS calls; flush GBREAK. +;;; Change "NIL" into "()". +;;; 09/13/76 jonl - changed loading message for qio, removed "M" from +;;; toplevel setqs +;;; 11/01/75 jonl - Fixed up the autoload properrty makers for slashify etc. +;;; 10/10/75 jonl - Added mem-form property for fillarray +;;; 09/18/75 jonl - Fixed up a few newio goodies, and removed more grind +;;; stuff to gfile +;;; 08/07/75 jonl - Flushed newio macroified stuff, and made dynamic +;;; 06/14/75 jonl - Flushed remgrind. repaired ghash to work on dec-10 +;;; 05/7/75 ? - Vertical-bars and exclamations slashed +;;; 09/21/74 maxpan made into 3 arg fn. third arg = m. /Eliminate +;;; excessive specbinding. grindpredict obtained via apply. + +(herald GRINDEF /462) + + + +(declare (own-symbol READMACROINVERSE SPRINTER SPRIN1 GRINDEF + |MACROEXPANDED-grindmacro/|| |+INTERNAL-`-grindmacros/||)) + +(declare (array* (notype (gtab/| 128.))) + (special /; /;/; /;/;? arg chrct comnt comspace gap global-lincnt + grind-standard-quote grindef grindfill grindfn grindform + grindlinct grindmacro grindmerge grindnomerge grindpredict + grindproperties grindreadtable h l linel m macro n outfiles + pagewidth gpredict prog? programspace readtable remsemi + sprin1 + topwidth unbnd-vrbl user-paging hunksprin1 grind*rset + grlinel grind-macroexpanded) + (*expr grindform topwidth programspace pagewidth comspace + grindnomerge remsemi) + (*fexpr trace slashify unslashify grindfn grindmacro + unreadmacro readmacro grindef) + (*lexpr grindmerge gpredict user-paging grindfill testl) + (*expr prin50com rem/;/; rem/;) ;; Imported from GFILE + (mapex 't) + (genprefix /|gr) + (fixnum nn mm + (prog-predict notype fixnum fixnum) + (block-predict notype fixnum fixnum) + (setq-predict notype fixnum fixnum) + (panmax notype fixnum fixnum) + (maxpan notype fixnum fixnum) + (gflatsize) (grchrct) (grlinel))) + +(cond ((not (boundp 'hunksprin1)) + (setq hunksprin1 'standard-hunksprin1))) +(cond ((not (boundp 'grind*rset)) + (setq grind*rset ()))) + +;;;REMSEMI - test and call + +(declare (setq defmacro-for-compiling () defmacro-displace-call () )) + + (defmacro remsemi-tac () '(and remsemi (remsemi))) + (defmacro popl () '(progn (pop l) (remsemi-tac) l)) + ;;; replaced by compiler by tab (8 its, 10. multics) + (defmacro stat-tab () `(quote ,(status tabsize))) + #+multics + (defsimplemac ghash (x) + `(cond ((atom ,x) (abs (sxhash ,x))) + ((maknum ,x)))) + #-multics + (defmacro ghash (x) `(maknum ,x)) + + +(prog (*RSET) + (*rset grind*rset) + ;;;some initializations + (and (not (boundp 'grind-use-original-readtable)) + (setq grind-use-original-readtable 't)) + ;;; standard readmacroinverter for quote. "quote" + ;;; If you have your own macro for quote take effect, set + ;;; grind-standard-quote to (). + (and (not (boundp 'grind-standard-quote)) + (setq grind-standard-quote 't)) + (setq remsemi () + grindlinct 8. + grindef () + global-lincnt 59. + grindproperties '(expr fexpr value macro)) + (array gtab/| t 128.)) + + + +;;; (GRINDEF ...) +;;; Grinds the properties of the atoms listed on GRINDPROPERTIES. +;;; +;;; (GRINDEF ( ...) ...) +;;; grinds the additional properties as well. + +(defun grindef fexpr (atoms) + (let ((linel (grlinel)) (*rset grind*rset) (nouuo grind*rset)) + (prog (traced fn props) + (cond (atoms (setq grindef atoms)) + ((setq atoms grindef))) + (setq props grindproperties) + a (cond ((null atoms) (return '*))) + (setq fn (car atoms) atoms (cdr atoms)) + (cond ((atom fn) (and (not (symbolp fn)) (go a))) + ((setq props (append fn props)) (go a))) + ;;; flag for fn being traced + (cond ((setq traced (and (status feature trace) + (memq fn (trace)))) + (terpri) + (terpri) + (princ '/;traced))) + (do + ((plist (plist fn) (cddr plist)) + (ind 'value (car plist)) + (prop (and (boundp fn) (cons () (eval fn))) + (cadr plist)) + ;;; needed in case there are value properties + (valueless () 't)) + (()) + (cond ((and traced + ;;; ignore all but last if traced + (memq ind '(expr fexpr macro))) + (setq traced (get (cdr plist) ind)) + (go b)) + ;;; grindef only desired properties. + ((not (memq ind props)) (go b)) + ((eq ind 'value) + (cond ((and prop (not valueless)) + (terpri) + (terpri) + (sprint `(setq ,fn (quote ,(cdr prop))) + linel + 0.))) + (go b))) + (terpri) + ;;; terpri's placed here to avoid + (terpri) + ;;; lambda -> defun + (cond ((and (memq ind '(expr fexpr macro)) + (eq (car prop) 'lambda)) + (sprint (cons 'defun + (cons fn + (cond ((eq ind 'expr) + (cdr prop)) + ((cons ind + (cdr prop)))))) + linel + 0.)) + ((sprint `(defprop ,fn ,prop ,ind) + linel + 0.))) + b + ;;; exit from do when no more properties + ;;; look for more atoms to do. + (or plist (return ()))) + (go a)))) + +;;; (unformat fn1 fn2 ...) or (unformat (fn1 fn2 ...)) +;;; Removes grinding information from the each of a list of functions. + +(defun unformat fexpr (x) + (or (atom (car x)) (setq x (car x))) + (mapc '(lambda (x) (remprop x 'grindfn) + (remprop x 'grindmacro) + (remprop x 'grindpredict) + (remprop x 'gflatsize)) + x)) + +;;; eg (grindmacro quote /') + +(defun grindmacro fexpr (y) + (putgrind (car y) (cdr y) 'grindmacro)) + +;;; eg (grindfn (defun defmacro) def-form) + +(defun grindfn fexpr (y) + (putgrind (car y) (cdr y) 'grindfn)) + +;;; (PUTGRIND ) +;;; +;;; may be a function-name or a list of function-names +;;; (in which case, the operation will be distributed recursively +;;; across the list) +;;; +;;; must be a list. ... more documentation needed ... + +(defun putgrind (fn prop ind) + (cond ((atom fn) + (setq prop + (cond ((atom (car prop)) + (cond ((get (car prop) 'grindpredict) + (putprop fn + (get (car prop) 'grindpredict) + 'grindpredict))) + (car prop)) + ('t (cond ((eq (caar prop) 'readmacroinverse) + (putprop fn + (get 'readmacroinverse 'grindpredict) + 'grindpredict))) + (cons 'lambda (cons () prop))))) + (putprop fn prop ind)) + ('t (mapc '(lambda (x) (putgrind x prop ind)) fn)))) + + +;;; eg (readmacro quote /' ) +;;; where optional means grind CDR instead of CADR. + +(defun readmacro fexpr (y) + (putgrind (car y) + (list (cons 'readmacroinverse + (cons (cadr y) (cddr y)))) + 'grindmacro)) + +;;; remove readmacro info from a character + +(defun unreadmacro fexpr (y) (remprop y 'grindmacro)) + +;;; *** If you know what this does, please document it --kmp *** + +(defun grindmacrocheck (x l) + (cond ((or (atom x) (cdr x)) ()) + ((null (car x)) (= (length l) 2.)) ;x = (()) + ((equal (car x) '(t)) (cdr l)))) ;x = ((t)) + +;;; (readmacroinverse ) --> . +;;; Macro-char may be an atom or list of ascii values. +;;; Note that it expects the special variable L to have info about the +;;; form which is being printed. + +(defun readmacroinverse fexpr (x) + (prog (sprarg) + (cond ((cond ((null (cdr x)) (= (length l) 2.)) + ((and (null (cddr x)) (eq (cadr x) 't)) (cdr l))) + (cond ((atom (car x)) (princ (car x))) + ((mapc 'tyo (car x)))) + ;;; macro must have arg to execute inverse + (setq sprarg (cond ((null (cdr x)) (cadr l)) + ((eq (cadr x) 't) (cdr l)) + ((= (length (cdr l)) 1.) + (cond ((null (cadr l)) + (tyo #\space) + (return 't)) + ('t (cadr l)))) + ('t (cdr l)))) + (cond ((sprint1 sprarg (grchrct) m) + (prin1 sprarg))) + (return 't)) + ('t (return ()))))) + +;;; GATOMP - ATOM check for proper (?) handling of hunks. REES 4/2/80 +;;; Returns true for objects which should NOT be iteratively +;;; CDRed during analysis. + +(defun gatomp (x) + (or (atom x) + (and (hunkp x) hunkp hunksprin1))) + +;;; Format for LAMBDA and LET +;;; +;;; (name bvl body) if it all fits on one line. +;;; else (name bvl +;;; body) with 3 spaces indentation. +;;; + +(defun lambda-form () + (let ((obj (car l))) + (grindform 'line) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg (gflatsize obj))))) + (grindform 'block))) + + + +(eval-when (eval compile) (tyipeek 12.) ) ; skip debugging stuff + + ;; debugging only + +(defun beep-trace (X) + (let (((v . h) (cursorpos tyo))) + (tyo 7.) + (cursorpos 23. 50. tyo) + (princ'*) (princ x) + (cursorpos v h tyo) + (rubout(tyi)) + (cursorpos 23. 70. tyo) + (cursorpos'l tyo) + (cursorpos v h tyo))) + + + +(defun do-form () + (let ((c-ct (grchrct)) (c-ct2) (gflag 't)) +; (beep-trace 'do) + (grindform'line) + (setq c-ct2 (grchrct)) + (grindform'code) + (cond ((not (and gpredict (< (grchrct) (gflatsize (testl))))) + (setq gflag 't) + (indent-to c-ct2))) + (grindform'code) + (and gflag (indent-to c-ct)) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg 3.)))) + (setq prog? 't) + (grindform 'block))) + +; Experimental: -kmp +;(defun cond-form () +; (beep-trace 'cond) +; (let ((cct (- (grchrct) 5.))) +; (grindform'line) +; (cond ((not (and gpredict +; (< (grchrct) (gflatsize (testl))))) +; (do ((flag nil t)) ((done? cct)) +; (and flag (indent-to cct)) +; (grindform'code))) +; (t +; (grindform'block))))) +; +;(grindfn (cond) cond-form) + +;;; Format for PROG's +;;; prohibits form3 if args do not fit on line + +(defun prog-form () +; (beep-trace'prog) + (grindform 'line) + (setq prog? 't) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + (arg))) + (grindform 'block)) + + +;;; prohibits form3 if args do not fit on line + +(defun def-form () + (prog (c) + (setq c (car l)) + (grindform 'line) + (grindform 'line) + go (cond ((memq (testl) '(expr fexpr macro)) + (grindform 'line) + (go go))) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg (gflatsize c))))) + (return (grindform 'block)))) + +;;; quoted second arg ground as block + +(defun mem-form () + (prog (p gm) + (grindform 'line) + (remsemi-tac) + (*catch () + (and (setq p (panmax (car l) (grchrct) 0.)) + (cond ((< (panmax (car l) n 0.) p)) + ((setq n (grchrct)))))) + (cond ((sprint1 (car l) n 0.) (prin1 (car l)))) + a (cond ((null (cdr l)) + (setq l (error 'mem-form l 'fail-act)) + (go a))) + (popl) + go (indent-to n) + (setq m (1+ m)) + (cond ((eq (caar l) 'quote) + (tyo #/') + (cond ((pprin (cadar l) 'block)) + ((prin1 (cadar l))))) + ((setq gm (sprint1 (car l) n m)) + (prin1 (car l)))) + (popl) + (cond (l (go go)) ((return ()))))) + +;;; standard form +;;; committed to at least standard form +;;; prediction in special form computed to +;;; compare to p. +;;; setq form + +(defun setq-form () + (cond ((*catch () + (prog (mm) + (setq mm (maxpan (cdr l) arg m)) + (setq n arg) + (defprop setq setq-predict grindpredict) + (and (< mm (panmax l (prog2 () (1+ n) + (setq n arg)) + m)) + (return 't)) + (grindform 'line) + d (or l (return ())) + (indent-to n) + (grindform 'line) + (grindform 'code) + (remsemi-tac) + (go d))) + ;;; SETQ-PREDICT causes throw when variable name is very long. + ;;; therefore, it is not used all the time but only inside + ;;; setq-form. + (defprop setq () grindpredict) + (grindform 'line) + (setq grindform n)))) + + + + + +;;; grinds l with args outputed as list. + +(defun comment-form () (gblock (- (grchrct) 1. (gflatsize (car l))))) + +(defun block-form () (gblock (grchrct))) + + + +(declare (unspecial l n m)) + +;;; returns number of lines to print args +;;; as name-value pairs. +;;; n = space for namevalue. 2 = +;;; space for ( and . +;;; nn = space for value. 2 = space for ) +;;; and . + +(defun setq-predict (l n ()) ; m omitted -- not used + (prog (mm nn) + (setq n (- n 2. (gflatsize (car l)))) + (setq mm 0.) + a (and (null (setq l (cdr l))) (return mm)) + (and (semi? (car l)) (go a)) + (setq nn (- n 2. (gflatsize (car l)))) + b (cond ((null (cdr l)) + (setq l (error 'setq-predict l 'wrng-no-args)) + (go b))) + (setq l (cdr l)) + (and (semi? (car l)) (go b)) + (setq mm (+ mm (panmax (car l) nn 0.))) + (go a))) + +(declare (special l n m)) + +;;;format control + +;;; (gpredict) <=> (gpredict t) => super-careful +;;; sprint considering all formats. (gpredict ()) +;;; => less careful but quicker. + +(defun gpredict args (setq gpredict (cond ((= args 0.)) ((arg 1.))))) + + ;;don't clobber user def. this is for compatibility only +(cond ((not (fboundp 'predict)) + (defprop predict gpredict expr))) + + +(defun programspace (x) + (setq programspace (setq linel x)) + (setq comspace (- pagewidth gap programspace))) + +(defun pagewidth (w x y z) + (setq pagewidth w) + (setq gap y) + (setq programspace (setq linel x)) + (setq comspace z)) + +(defun comspace (x) + (setq comspace x) + (setq programspace (setq linel (- pagewidth gap comspace)))) + +;;; (grindfill) <=> (grindfill t) => spaces gobbled in ; + +(defun grindpage () (tyo #\formfeed) (setq grindlinct global-lincnt)) + +;;; comments. (grindfill ()) => spaces not gobbled. +;;; triple semi comments are never filled but are +;;; retyped exactly inuser's original form. + +(defun grindfill args (setq grindfill (cond ((= args 0.)) ((arg 1.))))) + +;;; (grindmerge) <=> (grindmerge t) => adjoining ; and ;; +;;; comments are merged. (grindmerge ()) => adjoining +;;; comments not merged. ;;;... are never merged. + +(defun grindmerge args (setq grindmerge (cond ((= args 0.)) ((arg 1.))))) + +;;; (user-paging) <=> (user-paging t) +;;; grind does not insert any formfeeds, but +;;; preserves paging of user's file. (user-paging +;;; () ) => grind inserts formfeed every 59 lines. +;;; attempts to avoid s-expr pretty-printed over +;;; page boundary. ignores users paging. paging of +;;; user's file. + +(defun user-paging args + (setq user-paging (cond ((= args 0.)) ((arg 1.))))) + +(defun topwidth (x) (setq topwidth x)) + +;;; REMSEMI must be non-() + +(defun remsemi () + (do ((fl)) + ((cond ((rem/;) (rem/;/;) (setq fl 't) ()) + ((rem/;/;) (setq fl 't) ()) + ('t)) + fl))) + +;;; check for any ;;'s +;;; at any depth + +(defun semisemi? (k) + (cond ((null remsemi) ()) + ((eq k /;/;)) + ((gatomp k) ()) + ((or (semisemi? (car k)) (semisemi? (cdr k)))))) + +(defun semi? (k) (and remsemi (or (eq (car k) /;) (eq (car k) /;/;)))) + + +;;; indents additonal nn spaces. + +(defun indent (nn) + (cond ((minusp (setq nn (- (grchrct) nn))) + (error 'indent/ beyond/ linel? nn 'fail-act) + (terpri)) + ((indent-to nn)))) + + +;;; chrct set to nn +;;; chrct may become negative from +;;; prin50com. +;;; some indentation is necessary +;;; position as a result of first tab. +;;; tabs do not move 8, but +;;; to nearest multiple of 8 + +(defun indent-to (nn) + ((lambda (nct tab) + (declare (fixnum nct tab)) + (cond ((or (< nct 0.) (> nn nct)) + (turpri) + (setq nct linel))) + (cond ((< nn nct) + (setq tab (+ nct + (- (stat-tab)) + (\ (- linel nct) (stat-tab)))) + (cond ((< tab nn) (grindslew (- nct nn) #\space)) + ((tyo #\tab) + (setq nct tab) + (cond ((< nn nct) + (setq nct (- nct nn)) + (grindslew (// nct (stat-tab)) + #\tab) + (grindslew (\ nct (stat-tab)) + #\space)))))))) + (grchrct) + 0.)) + +(defun grindslew (nn x) (do mm nn (1- mm) (zerop mm) (tyo x))) + +;;; this global variable records whether the last +;;; form printed was a double-semi comment. if so, +;;; it is non-() and rem/;/; merges the current +;;; comment. this meging should not happen across +;;; a pprin. furthermore, it is a bug if pprin is +;;; printing code that is an atom. then /;/;? is +;;; not set to () and it falsely indicates tha the +;;; last form printed was a /;/; comment. l is +;;; = 'block or as a function followed by a list +;;; ground as line if tp = 'line, as a block if tp +;;; of arguments if l = 'list, or normally +;;; if tp = 'code. + +(defun pprin (l tp) + (setq /;/;? ()) + (cond ((atom l) (prin1 l) 't) + ((eq tp 'line) (cond ((gprin1 l n) (prin1 l))) 't) + ((eq tp 'block) + (or (and (symbolp (car l)) + ((lambda (x) (and x (apply x ()))) + (get (car l) 'grindmacro))) + (progn (princ '/() + (gblock (grchrct)) + (princ '/))))) + ((eq tp 'list) + (or (and (symbolp (car l)) + ((lambda (x) (and x (apply x ()))) + (get (car l) 'grindmacro))) + (progn (princ '/() + (gblock (- (grchrct) 1. (gflatsize (car l)))) + (princ '/))))) + ((eq tp 'code) (sprint1 l (grchrct) m) 't))) + + + +;;; cr with line of outstanding single semi +;;; comment printed, if any. grindlinct = +;;; lines remaining on page. + +(defun turpri () + (and remsemi comnt (prin50com)) + (terpri) + (setq grindlinct (cond ((= grindlinct 0.) global-lincnt) + ((1- grindlinct))))) + +;;; (grchrct) +;;; Returns the amount of room between the current horizontal position +;;; and the end of the line. For many applications, this is the right +;;; second arg to give to sprint1 on recursive pretty-print dives. + +(defun grchrct () + (- linel (charpos (car (or (and ^R outfiles) '(t)))))) + +;;; (grlinel) +;;; This is the linel of the output file that we are presumably grinding to + +(defun grlinel () + (cond ((boundp 'grlinel) grlinel) + ('t (linel (car (or (and ^R outfiles) '(t)) ))))) + +;;; KMP: Note -- this function is hairier than it needs to be. In current +;;; GFN and GFILE, it is ALWAYS called with no args. Somebody who is +;;; awake at the time should try to simplify it into something readable +;;; and/or scrap this package entirely and write something winning. + +(defun testl args + (prog (k nargs) + (setq k l nargs (cond ((= 0. args) 0.) ((arg 1.)))) + a (cond ((null k) (return ())) + ((semi? (car k)) (setq k (cdr k)) (go a)) + ((= 0. nargs) + (return (cond ((= 2. args) k) ('t (car k))))) + ((setq nargs (1- nargs)) + (setq k (cdr k)) + (go a))))) + +;;; pprin the car of l, then pops l. +;;; no-op if l is already (). process +;;; initial semi-colon comment, if any, +;;; then try again. pretty-print c(car l) +;;; in desired format. if l is not yet (), output +;;; a space. return popped l. + +(defun grindform (x) + (cond ((remsemi-tac) (grindform x)) + (l (cond ((pprin (car l) x) + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (setq l (cdr l))) + ('t (prin1 (car l)) + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (setq l (cdr l))))))) + +;;; pretty print over whole width + +(defun sprinter (l) + (let ((linel (grlinel)) (*rset grind*rset) (nouuo grind*rset)) + (turpri) + (turpri) + (sprint l linel 0.) + (turpri) + '*)) + +;;; For efficiency, the symbol SPRIN1 is a substitution alist for the +;;; function SPRIN1 to use. This actually does the wrong thing if TYO is +;;; rebound to something else, but fooey on people that do that. + +(setq sprin1 `((T . ,tyo))) + +;;; (SPRIN1 object [ optional-file-info ]) +;;; pretty-prin1's object to files specified or default output file if +;;; none given explicitly. No initial carriage return is typed by SPRIN1 +;;; so the form is displayed properly indented for the current horizontal +;;; position. + +(defun sprin1 (ll &OPTIONAL (files outfiles)) + (let ((*rset grind*rset) + (nouuo grind*rset) + (linel (grlinel)) + (^r 't) + (^w ^w) + (outfiles (progn (cond ((not files) ()) + ((atom files) (setq files (ncons files)))) + (sublis sprin1 files)))) + (and files (setq ^w 't)) + (sprint ll (grchrct) 0) + 't)) + +;;; This is the correct toplevel function to call when sprin1'ing a function. +;;; Clears the hash table and then calls sprint1. sprint1 is the correct +;;; function to recursively call. see doc on sprin1 for info on what the +;;; args l, m, and n do. + +(defun sprint (l n m) + (fillarray 'gtab/| '(())) + (sprint1 l n m)) + +;;;sprint formats +;;;form1 = (s1 form2 = (s1 s2 form3 = (s1 s2 (sprint1 last)) +;;; s2 s3) +;;; s3) + +;;; expression l to be sprinted in space n +;;; with m unbalanced "/)" hanging. p is +;;; number lines to sprint1 as form2 +;;; this is an explicit check for quote. +;;; the alternative is to use the standard +;;; grindmacro to use your own personal readmacro +;;; for quote, setq grind-standard-quote to (). +;;; if a ;; comnt, force multi-line +;;; +;;; p = # of lines to sprint l in standard + +(defun sprint1 (l n m) + (prog (grindform arg fn args p prog? grindfn form3? gm) + (and (remsemi-tac) (null l) (return ())) + (setq /;/;? ()) + (indent-to n) + (cond ((gatomp l) + (cond ((atom l) (prin1 l)) + ('t (funcall hunksprin1 l n m))) + (return ()))) + (cond ((and grind-standard-quote + (not (and hunkp + hunksprin1 + (hunkp l))) + (eq (car l) 'quote) + (cdr l) + (null (cddr l))) + (princ '/') + (setq gm (sprint1 (cadr l) (grchrct) m)) + (return ()))) + (and (symbolp (car l)) + (setq fn (car l)) + (let ((x (get fn 'grindmacro))) + (and x (apply x ()))) + (return ())) + (cond ((semisemi? l)) + ((< (+ m -1. (gflatsize l)) (grchrct)) + (return (gprin1 l n)))) + (princ '/() + (setq n (grchrct)) + (setq arg (- n (gflatsize (car l)) 1.)) + (and + (atom (setq args + (cond ((setq grindfn (get fn + 'grindfn)) + (apply grindfn ()) + (and (numberp grindform) + (setq n grindform) + (go b)) + (and (null l) + (princ '/)) + (return ())) + l) + ((cdr l))))) + (go b)) + ;; catch exited if space insufficient. + (*catch () + (and + (setq p (maxpan args arg m)) + ;;; Format. Exit if miser more efficient than standard + ;;; in no-predict mode, use miser format on all non-fn-lists. + (cond (gpredict (not (< (maxpan args n m) p))) + (fn)) + (setq n arg) + ;;; committed to standard format. + (cond + (grindfn (or (eq grindform 'form2) + (> (maxpan args (grchrct) m) p) + (setq n (grchrct)))) + ((prog () + ;;; skip form3 is gpredict=(). + (or gpredict (go a)) + (*catch () + ;;; l cannot be fit in chrct is it more + ;;; efficient to grind l form3 or form2 + (setq + form3? + (and (not (eq (car (last l)) /;)) + (< (maxpan (last l) + (- (grchrct) + (- (gflatsize l) + (gflatsize (last l)))) + m) + p)))) + a (setq gm (gprin1 (car l) n)) +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 always returns () nowadays. +;;; This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (gprin1 (car l) n)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- n 2.)) +;;; (setq l ()) +;;; (go b1)) +;;; (t (prin1 (car l)))))) +;;; + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (and (cdr (setq l (cdr l))) form3? (go a)) + b1 (setq n (grchrct))))))) + b (grindargs l n m))) + +;;; hunk L to be sprinted in space N with M unbalanced /)'s hanging... + +(defun standard-hunksprin1 (l n m) + (cond ((< (gflatsize l) (- n m)) + (standard-hunkprin1 l n m)) + ('t + (princ '|(|) + (do ((i 1. (1+ i)) + (m+3 (+ 3 m)) + (width (grchrct)) + (size (hunksize l))) + ((= i size) + (indent-to n) + (sprint1 (cxr 0. l) width m+3) + (princ '| .)|)) + (cond ((> i 1) (indent-to n))) + (sprint1 (cxr i l) width m+3) + (princ '| . |))))) + +(defun (standard-hunksprin1 hunkgflatsize) (x) + (declare (fixnum i s w)) + (do ((i 0. (1+ i)) + (s (hunksize x)) + (w 1. (+ w 3. (gflatsize (cxr i x))))) + ((= i s) w))) + +(defun standard-hunkprin1 (l n m) + (princ '|(|) + (do ((i 1. (1+ i)) + (m+3 (+ 3 m)) + (size (hunksize l))) + ((= i size) + (sprint1 (cxr 0. l) (grchrct) m+3) + (princ '| .)|)) + (sprint1 (cxr i l) (grchrct) m+3) + (princ '| . |))) + +;;; elements of l are ground one under the +;;; next +;;; prints closing paren if done. +;;; exception of tags which are unindented +;;; 5 + +(defun grindargs (l nn mm) + (prog (gm sprarg1 sprarg2) + a (and (done? nn) (return ())) + (setq sprarg1 + (cond ((and prog? + (car l) + (atom (car l))) + (+ nn 5.)) + (nn))) + (setq sprarg2 (cond ((null (cdr l)) (1+ mm)) + ((atom (cdr l)) + (+ 4. mm (gflatsize (cdr l)))) + (0.))) + (setq gm (sprint1 (car l) sprarg1 sprarg2)) + +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 and SPRINT1 always return () +;;; nowadays. This may not be the right thing -- they may not want +;;; to always return (), but this code will never get reached in the +;;; current state of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (sprint1 (car l) sprarg1 sprarg2)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (sprint1 l (- sprarg1 2.) sprarg2) +;;; (setq l ()) +;;; (go a)) +;;; (t (prin1 (car l)))))) +;;; + + (setq l (cdr l)) + (go a))) + +;;; if previous line a ;; comment, then do +;;; not print closing paren on same line as +;;; comment. +;;; prints closing "/)" if done + +(defun done? (nn) + (cond ((gatomp l) + (and /;/;? (indent-to nn)) + (cond (l (princ '/ /./ ) + (cond ((> (gflatsize l) (grchrct)) ; for hunks + (indent-to nn))) + (sprint1 l (grchrct) m))) + (princ '/)) + 't))) + + +;;; l printed as text with indent n. + +(defun gblock (n) + (prog (gm) + (and (remsemi-tac) (or l (return ()))) + a (cond ((gatomp l) + ;;; Hunks used to not get middle shown by grind. For + ;;; people that might have used this feature, we won't + ;;; treat hunks specially if HUNKSPRIN1 is not set to + ;;; the name of a printer. + (princ '|. |) + (prin1 l) + (return ())) + ((setq gm (gprin1 (car l) n)) + ;;; Result Omitted -- See below + )) + +;;; +;;; KMP: The previous COND used to have a consequent to its last clause, but +;;; since GPRIN1 always returns () nowadays, I have factored out that +;;; part. This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; ((setq gm (gprin1 (car l) n)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- n 2.)) +;;; (return (setq l ()))) +;;; (t (prin1 (car l))))) +;;; + + (or (popl) (return ())) + (cond ((< (gflatsize (car l)) (- (grchrct) 2. m)) + (tyo #\space) + (go a)) + ;;; non-atomic elements occuring in block + ;;; too large for the line are sprinted. + ;;; this occurs in the variable list of a prog. + ((and (not (atom (car l))) ;GATOMP? + (< (- n m) (gflatsize (car l)))) + (cond ((setq gm (sprint1 (car l) n m)) + ;;; KMP: I think this code can never be reached. + ;;; It looks like SPRINT1 always returns () + ;;; since it looks like GPRIN1 does too... + ;;; Can someone check me on this? Tnx. + (cond ((grindmacrocheck gm l) + (princ '/./ ) + (sprint1 l (- n 2.) m) + (return (setq l ()))) + ('t (prin1 (car l)))))) + (or (popl) (return ())))) + ;;; new line + (indent-to n) + (go a))) + +;;; prin1 with grindmacro feature. + +(defun gprin1 (l nn) + (cond ((gatomp l) + (cond ((hunkp l) (funcall hunksprin1 l nn m)) + ('t (prin1 l))) + ()) + ((prog (gm) + (remsemi-tac) + (and (atom (car l)) + (let ((x (get (car l) 'grindmacro))) + (and x (apply x ()))) + (return ())) + (princ '/() + (setq nn (1- nn)) + a (setq gm (gprin1 (car l) nn)) + +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 always returns () nowadays. +;;; This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (gprin1 (car l) nn)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- nn 2.)) +;;; (setq l ()) +;;; (go a1)) +;;; (t (prin1 (car l)))))) +;;; + + (popl) + a1 (and (done? nn) (return ())) + (tyo #\space) + (go a))))) + + + +(comment Special grind functions for system-related facilities) + + +;;; For use with "macroexpanded" forms + +(defun |MACROEXPANDED-grindmacro/|| () + (declare (special l m)) + (sprint1 (cond (grind-macroexpanded (nth 4 l)) ((nth 3 l))) + (grchrct) + m) + 't) + +;;; For help with "backquote" forms +;;; +;;; KMP: This function is put on the GRINDMACRO property of |`-expander/|| +;;; et al when the BACKQ package gets loaded. If you ask me, it should +;;; get set up at the time this package loads. + +(defun |+INTERNAL-`-grindmacros/|| () + (declare (special l m)) + (eval (cons 'readmacroinverse + (cdr (assq (car l) + '((|`-expander/|| |`| t) + (|`,/|| |,| t) + (|`,@/|| |,@| t) + (|`,./|| |,.| t)))))) + 't) + + + +;;prediction functions + +(declare (unspecial l n m)) + +;;;for increased speed, l n m are made unspecial in maxpan and panmax +;;; list of s expression one under the next +;;; estimates number of lines to sprint1 +;;; in space n + +(defun maxpan (l n m) + (declare (fixnum g)) + (prog (g) + (setq g 0.) + a (setq g + (+ g + (panmax (car l) + n + (cond ((null (setq l (cdr l))) (1+ m)) + ((gatomp l) (+ m 4. (gflatsize l))) + (0.))))) + (and (gatomp l) (return g)) + (go a))) + +;;; estimates number of lines to sprint1 an +;;; s expression in space n. less costly +;;; than sprint as prediction always chooses form2. +;;; if insufficient space, throws. + +(defun panmax (l n m) + (cond ((< (+ m -1. (gflatsize l)) n) 1.) + ((or (< n 3.) (atom l)) + (*throw () 40.)) ;should these "atom"s be + ((or (not (atom (car l))) (gatomp (cdr l))) ;"gatomp"'s? + (maxpan l (sub1 n) m)) + (((lambda (x) (and x (funcall x l n m))) + (get (car l) 'grindpredict))) + ((maxpan (cdr l) (- n 2. (gflatsize (car l))) m)))) + +(defun prog-predict (l n m) + ((lambda (nn) (+ (block-predict (cadr l) nn 1.) + (maxpan (cddr l) nn m))) + (- n 2. (gflatsize (car l))))) + +(defprop lambda-form prog-predict grindpredict) + +(defprop prog-form prog-predict grindpredict) + +;;; indent=spaces indented to margin of +;;; block. throw if insuff remaining space. +;;; number of lines approx by dividing size of l by +;;; block width. + +(defun block-predict (l n indent) + (cond ((> 1. (setq n (- n indent))) (*throw () 50.)) + ((1+ (// (- (gflatsize l) indent) n))))) + +;;; m not used. + +(defun block-predictor (l n () ) (block-predict l n 1.)) ; m = unused 3rd arg + +(defprop block-form block-predictor grindpredict) + +;;; m not used by block-predict. third arg +;;; represents indentation of block. + +(defun comment-predict (l n () ) ; m = unused 3rd arg + (block-predict l n (+ (gflatsize (car l)) 2.))) + +(defprop comment-form comment-predict grindpredict) + +(defun readmacroinverse-predict (l n m) + (panmax (cadr l) + (- n (cond ((atom (car l)) (flatc (car l))) + ('t (length (car l))))) + m)) + +(defprop readmacroinverse readmacroinverse-predict grindpredict) + + + +(declare (special l n m)) + +;;; user read macros. +;;; (eg (slashify $)). preserve slashes preceding + +(defun slashify fexpr (chars) (mapc 'slashify1 chars)) + +(defun unslashify fexpr (chars) (mapc 'unslashify1 chars)) + +;;; make char '-like readmacro. +;;; will be null only if char is single + +(defun slashify1 (char) + ((lambda (readtable) + (or (null (getchar char 2.)) + (setq char (error 'slashify + char + 'wrng-type-arg))) + (setsyntax char + 'macro + (subst char + 'char + '(lambda () (list 'char + (read))))) + (apply 'readmacro (list char char))) + grindreadtable)) + +(defun unslashify1 (char) + ((lambda (readtable) (or (null (getchar char 2.)) + (setq char + (error 'unslashify + char + 'wrng-type-arg))) + (setsyntax char 'macro ()) + (apply 'unreadmacro (list char))) + grindreadtable)) + + + +;;;(defun gflatsize (data) +;;; ((lambda (nn bucket) +;;; (setq bucket (gtab/| nn)) +;;; (cdr (cond ((and bucket (assq data bucket))) +;;; (t (car (store (gtab/| nn) +;;; (cons (setq data +;;; (cons data +;;; (flatsize data))) +;;; bucket))))))) +;;; (\ (ghash data) 127.) +;;; ())) + +(defun gflatsize (data) + ((lambda (nn bucket) + (setq bucket (gtab/| nn)) + (cdr (cond ((and bucket (assq data bucket))) + ('t (car (store (gtab/| nn) + (cons (setq data + (cons data + (gflatsize1 data 't))) + bucket))))))) + (\ (ghash data) 127.) + ())) + +(defun +internal-dwim-predictfun (l n ()) + (cond ((> (gflatsize1 l 't) n) (*throw () 40.)) + ('t 1.))) + +;;; (GFLATSIZE1 L FLAG) +;;; This is a hook into the gflatsize process that says that we want L's +;;; + +(defun gflatsize1 (l flag) + (cond ((gatomp l) + (let ((fsize-fun (and (hunkp l) + (get hunksprin1 'hunkgflatsize)))) + (cond (fsize-fun (funcall fsize-fun l)) + ('t (flatsize l))))) + ((and flag + (symbolp (car l)) + (let ((fsize-fun (get (car l) 'grindflatsize))) + (cond (fsize-fun + (funcall fsize-fun l)))))) + ('t + (do ((len 2. (+ len + (gflatsize1 (car ll) 't) + (cond ((eq l ll) 0.) ('t 1.)))) + (ll l (cdr ll))) + ((gatomp ll) + (cond ((null ll) len) + ('t (+ len 3. + (let ((fsize-fun (and (hunkp ll) + (get hunksprin1 + 'hunkgflatsize)))) + (cond (fsize-fun + (funcall fsize-fun ll)) + ('t (flatsize ll)))))))))))) + +(defun gflatsize=1+cdr (l) + (1+ (gflatsize1 (cdr l) 't))) + +(defun gflatsize=2+cdr (l) + (+ (gflatsize1 (cdr l) 't) 2.)) + +(defprop |`-expander/|| gflatsize=1+cdr grindflatsize) +(defprop |`,/|| gflatsize=1+cdr grindflatsize) +(defprop |`,@/|| gflatsize=2+cdr grindflatsize) +(defprop |`,./|| gflatsize=2+cdr grindflatsize) + +(defun (/' grindflatsize) (l) + (cond ((and grind-standard-quote (= (length l) 2.)) + (+ 1. (gflatsize1 (cadr l) 't))) + ((+ 8. (gflatsize1 (cdr l) ()))))) + +(mapc (function + (lambda (x) + (putprop x '+internal-dwim-predictfun 'grindpredict))) + '(quote |`-expander/|| |`,/|| |`,@/|| |`,./||)) + + + +;;; default formats +;;; still need to define the standard macro + +(readmacro quote /') + +(grindfn (grindfn grindmacro) (grindform 'line) + (grindform 'block)) + + ;; let needs its own thing... +(grindfn (lambda eval-when) lambda-form) + +(grindfn (do) do-form) + + ;; caseq needs to do something much like def-form +(grindfn (defun defun/& defmacro) def-form) + +(grindfn prog prog-form) + +(grindfn (comment remob **array *fexpr *expr *lexpr special unspecial fixnum flonum) comment-form) + +(grindfn (member memq map maplist mapcar mapcon mapcan mapc assq + assoc sassq sassoc getl fillarray) mem-form) + +(grindfn setq setq-form) +(grindfn setf setq-form) + +(gpredict ()) + +;;;the following default formats are relevant only to grinding files. +;;;however, they appear here since the format fns are not defined +;;;in gfile and gfn is not loaded until after gfile. +;;default formats + +(pagewidth 112. 70. 1. 41.) + +(topwidth 110.) + +(grindmerge 't) + +(grindfill 't) + +(user-paging ()) + + + +;;; The GRINDREADTABLE is tailored for grind. + +((lambda (m) + (and (or (not (boundp 'grindreadtable)) + (null grindreadtable)) + ((lambda (readtable) + ;;; ^L made noticeable. + (setsyntax 12. 'single ()) + ;;; No auto cr. are inserted by lisp when + (sstatus terpri 't) + (setsyntax '/; + 'splicing + 'semi-comment)) + (setq grindreadtable + (*array () + 'readtable + grind-use-original-readtable)))) + + (cond ((or m (status feature maclisp)) + (let ((grindform (status userid)) + (comnt (cond ((status status homed) (status homed)) + ((status udir)))) + (defaultf defaultf) + l h) + (setq h (cons (list 'dsk comnt) + (cond ((status feature its) + (cons grindform '(grind))) + ('(grind ini))))) + (cond ((cond ((setq l (probef h))) + ((status feature its) + (rplaca (cdr h) '*) + (and + ((lambda (errset) + (setq l + (car + (errset + (funcall + (cond ((status feature sail) + 'eopen) + ('open)) + h + '(nodefault)) + () )))) + ()) + (setq l (truename l))) + l)) + (or (status feature noldmsg) + (prog2 (princ '|Loading GRIND init file| msgfiles) + (terpri msgfiles))) + (and + (atom (errset (funcall (cond ((status feature sail) + 'eload) + ('load)) + l) + 't)) + (princ '| *** ERRORS DURING LOADING *** BEWARE!| + msgfiles)))))) + ;;; loader for start_up.grind file + ('t (errset (load (list (status udir) + 'start_up + 'grind)) + ())))) + (status feature its)) + +(sstatus feature grindef) + +;;;;;;;;;;;;;;;;;;;;;; Bug Notes // Feature requests ;;;;;;;;;;;;;;;;;;;;; +;;; +;;; [ALAN (07/29/80)] Re: GRINDEF +;;; GRINDEF, SPRIN1 and friends don't seem to understand about +;;; (SSTATUS USRHU ...) etc. +;;; +;;; [KMP (09/23/80)] Re: GRINDEF +;;; The variable GRINDEF should be SETQ-IF-UNBOUND'd or something like that +;;; rather than just SETQ'd when the GRIND package loads. +;;; +;;; [ALAN (09/26/80)] Re: Old Style DO +;;; ... why don't you make it understand old-style DO? +;;; +;;; [SOLEY (09/26/80)] Re: GRINDEF +;;; In NILE;DOC >, the function DOCUMENTOR grinds terribly. +;;; +;;; [ALAN (09/29/80)] Re: Old-Style DO +;;; Date: 29 September 1980 1115-EDT (Monday) +;;; From: Guy.Steele at CMU-10A +;;; Recall that one can always convert old-style DO to new-style +;;; simply by inserting six parentheses: +;;; (DO X INIT STEP TEST BODY) => (DO ((X INIT STEP)) (TEST) BODY) +;;; SO a quick way out is just to grind every old-style DO as a new-style +;;; one, by this conversion (this amounts to an implicit declaration of war +;;; against old-style DO as being obsolete). +;;; I'm not sure I really advocate this -- just pointing out the +;;; possibility. +;;; ----- +;;; barf +;;; +;;; [Source: BEN@ML (09/24/80)] Re: GRIND mangles end-of-line comments +;;; In TOPS-10 MACLISP at Tufts (though I suspect elsewhere, too), GRINDing +;;; a file that includes end-of-line comments frequently puts the comments on +;;; the following line, unprotected by semi-colons. When this is loaded into +;;; LISP, we get lots of undefined value errors. (At installations that could +;;; run EMACS, no one would have to run GRIND, but . . .) Ben +;;; +;;; [Source: KMP,SRF,DANIEL (09/19/80)] Re: GRINDEF/TRACE interaction +;;; (DEFUN F (X) X) ; Define a function +;;; (GRINDEF F) ; Grinds just fine +;;; (TRACE F) ; Traces just fine +;;; (GRINDEF F) ; Grinds just fine with note that it's traced +;;; (DEFUN F (Y) Y) ; Redefine without untracing +;;; (GRINDEF) ; Claims traced. Doesn't grind +;;; (UNTRACE F) ; Untrace doesn't break the F(y) definition +;;; (GRINDEF F) ; Grinds just fine as F(y) +;;; ----- +;;; If there is a more recent definition than the traced definition, GRINDEF +;;; should allow that definition to supersede the trace information. +;;; +;;; [Reply-To: HMR, RWK, REES] Vectors +;;; Context: XNIL of 03/17/80 +;;; (defun foo (x) #(A B)) +;;; FOO +;;; (grindef foo) +;;; DEFUN FOO (X) # +;;; (A)) +;;; * +;;; ; Missing paren, broken over line +;;; +;;; [CWH] Re: TYO +;;; Make (TYO 100) => (TYO #/@), (TYO 11) as (TYO #\TAB), etc. +;;; +;;; [PRATT (3/18/80)] Re: ##MORE## +;;; Is grindef supposed to work correctly in conjunction with the standard +;;; more-processing? It seems like it gets confused about whether an +;;; s-expression will fit on the current line when that line follows ##MORE##. +;;; +;;; The following functions need special grind handlers -- +;;; DEFMACRO, CASEQ (Maybe like LAMBDA? -JAR), DEFUN& (-RLB), SETF (-RWK) +;;; +;;; #PRINT / GPRINT +;;; Waters' printer lives in LIBLSP;GPRINT. See LIBDOC;GPRINT for details. +;;; DICK;LSPMP QFASL is a version of GPRINT which will run on the LispMachine. +;;; +;;; [Reply-To: BKERNS (05/22/80)] Re: Prin{level/length} +;;; How hard would it be to make the grinder know about prinlength and +;;; prinlevel? I'm in desperate need of such a feature. +;;; +;;; [Reply-To: ALAN (06/28/80)] Re: GRINDEF +;;; ... since we will continue to support old-style DO can we please have it +;;; grind properly? Please?? ... +;;; +;;; [Reply-To: RLB (06/29/80)] Re: GRINDEF (In-Reply-To: ALAN's note) +;;; Seconded by me. Language redesign shouldn't happen defacto by causing +;;; constructs which you find distasteful to become otherwise distasteful to +;;; others. Is this paranoia or unusual perceptiveness? +;;; +;;; [Reply-To: ALAN (09/18/80)] Re: GRINDEF +;;; Is anybody EVER going to fix grindef to understand old-style do? +;;; +;;; *** Don't forget crlf after this line! *** + diff --git a/src/lspsrc/lap.110 b/src/lspsrc/lap.110 new file mode 100755 index 00000000..163a1e16 --- /dev/null +++ b/src/lspsrc/lap.110 @@ -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)) diff --git a/src/lspsrc/sort.13 b/src/lspsrc/sort.13 new file mode 100755 index 00000000..2bdf1a80 --- /dev/null +++ b/src/lspsrc/sort.13 @@ -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-,[ +IFNDEF D10, D10==0 +DEFINE $INSRT $%$%$% + .INSRT $%$%$% > + PRINTX \ ==> INSERTED: \ + $FNAME .IFNM1 + PRINTX \ \ + $FNAME .IFNM2 +PRINTX \ +\ +TERMIN +] ;END OF IFE .OSMIDAS-, +IFE .OSMIDAS-,[ +IFNDEF D10, D10==1 +DEFINE $INSRT $%$%$% + .INSRT $%$%$%!.MID + PRINTX \INSERTED: \ + $FNAME .IFNM1 + PRINTX \.\ + $FNAME .IFNM2 +PRINTX \ +\ +TERMIN +] ;END OF IFE .OSMIDAS-, + +IFNDEF $INSRT, .FATAL SO WHAT KIND OF OPERATING SYSTEM IS THIS ANYWAY??? + +DEFINE $FNAME FOO ;PRINTX A FILE NAME GIVEN NUMERIC SIXBIT +ZZX== +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 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= +IFSN F,-, SORT!OP= +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 + \ No newline at end of file diff --git a/src/lspsrc/trace.67 b/src/lspsrc/trace.67 new file mode 100755 index 00000000..aa50105a --- /dev/null +++ b/src/lspsrc/trace.67 @@ -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) diff --git a/src/lspsrc/vector.74 b/src/lspsrc/vector.74 new file mode 100755 index 00000000..75feea16 --- /dev/null +++ b/src/lspsrc/vector.74 @@ -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)))) + + \ No newline at end of file diff --git a/src/nilcom/backq.53 b/src/nilcom/backq.53 new file mode 100755 index 00000000..6a683335 --- /dev/null +++ b/src/nilcom/backq.53 @@ -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 "," + ((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 ",@" or ",." + (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) + diff --git a/src/nilcom/defmac.166 b/src/nilcom/defmac.166 new file mode 100755 index 00000000..2f3fb251 --- /dev/null +++ b/src/nilcom/defmac.166 @@ -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 ( ) if there is no +;;; variable in the which appears in . +;;;Otherwise, have to substitute for , 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 ( . 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))) + diff --git a/src/nilcom/defmax.98 b/src/nilcom/defmax.98 new file mode 100755 index 00000000..c26d14bb --- /dev/null +++ b/src/nilcom/defmax.98 @@ -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 +;;; +;;; +;;; ) +;;; Thereafter, the macro named MACROEXPANDED will +;;; return the until either the value of +;;; MACRO-EXPANSION-USE changes, or +;;; 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 ) + ;; 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)))))) + + + diff --git a/src/nilcom/defvst.164 b/src/nilcom/defvst.164 new file mode 100755 index 00000000..5c6ceb4f --- /dev/null +++ b/src/nilcom/defvst.164 @@ -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 = ( ...) + (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) + () )))) + diff --git a/src/nilcom/defvsx.106 b/src/nilcom/defvsx.106 new file mode 100755 index 00000000..a2801175 --- /dev/null +++ b/src/nilcom/defvsx.106 @@ -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)) + ) + + diff --git a/src/nilcom/defvsy.84 b/src/nilcom/defvsy.84 new file mode 100755 index 00000000..5df1ab44 --- /dev/null +++ b/src/nilcom/defvsy.84 @@ -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 "( )" + ;; where is the structure name, and 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) + ) + diff --git a/src/nilcom/errck.30 b/src/nilcom/errck.30 new file mode 100755 index 00000000..f7cbed4a --- /dev/null +++ b/src/nilcom/errck.30 @@ -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))) + diff --git a/src/nilcom/macaid.120 b/src/nilcom/macaid.120 new file mode 100755 index 00000000..89899eef --- /dev/null +++ b/src/nilcom/macaid.120 @@ -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 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))) + diff --git a/src/nilcom/setf.293 b/src/nilcom/setf.293 new file mode 100755 index 00000000..e321218f --- /dev/null +++ b/src/nilcom/setf.293 @@ -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))))) + + + + diff --git a/src/nilcom/setf.294 b/src/nilcom/setf.294 new file mode 100644 index 00000000..5c2f0cd5 --- /dev/null +++ b/src/nilcom/setf.294 @@ -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))))) + + + + diff --git a/src/nilcom/subseq.39 b/src/nilcom/subseq.39 new file mode 100755 index 00000000..0ff638e2 --- /dev/null +++ b/src/nilcom/subseq.39 @@ -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-, which take in any kind of +;;; sequence, and give out a corresponding sequence of type . +;;; 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- + + +(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)))) + ) diff --git a/src/nilcom/yesnop.44 b/src/nilcom/yesnop.44 new file mode 100755 index 00000000..8d4ff301 --- /dev/null +++ b/src/nilcom/yesnop.44 @@ -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))))))))))) + +