github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-02-08 01:11:18 +00:00
Code Issues Releases Wiki Activity

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

Browse Source 
the lisp interpreter is first booted.

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

File diff suppressed because it is too large Load Diff

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

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

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

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

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

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

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

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