github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-29 21:30:57 +00:00
Code Issues Releases Wiki Activity

Added lots of new LSPLIB packages (and their sources).

Browse Source
This commit is contained in:
Eric Swenson
2018-03-16 13:50:36 -07:00
parent 13244c1d61
commit 92db560d8f
118 changed files with 35842 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

617
src/nilcom/let.98 Executable file
View File

@@ -0,0 +1,617 @@
;;; LET -*-mode:lisp;package:si-*- -*-LISP-*-
;;; **************************************************************************
;;; ******** NIL ******** LET With Destructuring ****************************
;;; **************************************************************************
;;; ******** (C) Copyright 1981 Massachusetts Institute of Technology ********
;;; ************ THIS is a read-only file! (all writes reserved) *************
;;; **************************************************************************
;;; For MacLISP, to compile NALET (version which destructures over vectors),
;;; just load the SHARPC module, and set TARGET-FEATURES to 'NILAID
#M (include ((lisp) subload lsp))
(herald LET /98)
#M (eval-when (eval compile)
(subload SHARPCONDITIONALS)
)
;;Remember: a NILAID also will be a MacLISP
#+(or LISPM (and NIL (not MacLISP)))
(progn (globalize "LET")
(globalize "LET*")
(globalize "DESETQ"))
(eval-when (eval compile)
#+(or MacLISP LISPM)
(set-feature 'BadNULL)
#+(and MacLISP NIL)
(progn (subload VECTOR) (subload EXTMAC))
#+(local MacLISP)
(progn ;; Suppress spurious compiler messages
(mapc '(lambda (x) (putprop x 'T 'SKIP-WARNING))
'(|LET.decompose| |LET.step&decompose| |LET.anyvarsp|
|LET.make-list| DESETQ LET* LET))
(setq MUZZLED 'T))
)
(declare (special |LET.dcmp-tempvars| |LET.gensym-tempvars?|)
(*expr |LET.decompose| |LET.do-1-atom| |LET.step&decompose|
;; Generally, |LET.make-list| macroifies into MAKE-LIST
#-(or LISPM NIL) |LET.make-list|
|LET.match-vars| |LET.anyvarsp| |LET.optimize| )
(fixnum I LN)
(mapex 'T))
(setq |LET.gensym-tempvars?| #Q () #-LISPM 'T )
;;;; Temporary macros
(eval-when (eval compile)
;;; Leave these as defined by "macro" rather than "defmacro", so that
;;; one has a ghost of a chance of interpreting this file.
;;; Leave inside the eval-when so that the fool LISPM can win
(macro TRUTHITY (x)
#-NIL ''T
#N *:TRUTH
)
(macro NON-NULL-SYMBOL (x)
#+BadNULL `(AND ,(cadr x) (SYMBOLP ,(cadr x)))
#-BadNULL `(SYMBOLP ,(cadr x))
)
(macro QSEQUENCEP (x)
#-NIL `(NOT (ATOM ,(cadr x)))
#N `(TYPECASEQ ,(cadr x)
((PAIR VECTOR VECTOR-S) 'T)
(T () ))
)
;;; Here is the non-destructuring version of LET!
(macro BIND-LET (x)
((lambda (ll w vars vals)
(do ((l ll (cdr l)))
((null l))
(push (cond ((atom (car l)) (push () vals) (car l))
('T (push (cadar l) vals) (caar l)))
vars))
`((LAMBDA (,.(nreverse vars)) ,.w) ,.(nreverse vals)))
(cadr x) (cddr x) () () ))
;;; DOMAP-AND evaluates a form, on successive tails of a list, returning ()
;;; if any of the evaluations if (), and returning the last one if not.
;;; DOMAP-OR returns the first non-() one, or () if all are ().
;;; Syntax is (DOMAP-and/or (VAR1 <first-form>) ... (VARn <last-form>) <pred>)
;;; Items in angle-brackets are evaluated, and the names "VARi" are used
;;; as the stepping variables to use; <pred> is a "predicate" form.
;;; Typical use - (DOMAP-AND (TEMP DATA-LIST) (NOT (LOSEP (CAR TEMP))))
(macro DOMAP-AND (x)
(bind-let ((forms (cdr x)) pred (g (gensym)))
(setq pred (car (setq forms (reverse forms)))
forms (nreverse (cdr forms)))
`(DO ((,g)
,.(mapcar #'(lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x))))
forms))
((NOT (AND ,.(mapcar #'CAR forms))) ,g)
(OR (setq ,g ,pred) (RETURN () )))))
(macro DOMAP-OR (x)
(bind-let ((forms (cdr x)) pred (g (gensym)))
(setq pred (car (setq forms (reverse forms)))
forms (nreverse (cdr forms)))
`(DO ((,g)
,.(mapcar #'(lambda (x) `(,(car x) ,(cadr x) (CDR ,(car x))))
forms))
((NOT (AND ,.(mapcar #'CAR forms))) () )
(AND (setq ,g ,pred) (RETURN ,g)))))
(macro |LET.repeated?| (x)
(bind-let ((l (gensym)))
`(DO ((,l ,(cadr x)))
((NULL ,l) () )
(AND (MEMQ (CAR ,l) (CDR ,l)) (RETURN 'T))
(POP ,l))))
(macro PUSHNRL (x)
(bind-let ((item (cadr x)) (lname (caddr x)))
`(SETQ ,lname (NRECONC ,item ,lname))))
;;; Renamings! Due to certain symbols already being in pure LISP etc.,
;;; so its cheaper to use them, but these names are more descriptive.
(macro |LET.do-a-subform| (x) `(|LET.step&decompose| ,. (cdr x)))
(macro |LET.find-rightmost| (x)
`(|LET.match-vars| () ,(cadr x) -1 () ))
(macro |LET.in-pattern?| (x)
`(|LET.match-vars| ,(cadr x) ,(caddr x) +1 () ))
(macro NOVARS? (x) `(NOT (|LET.match-vars| () ,(cadr x) +1 () )))
(macro |LET.listallvars| (x)
`(|LET.match-vars| (truthity) ,(cadr x) +1 ,(caddr x)))
#-NIL
(eval-when (eval compile)
(defun TYPECASEQ macro (w)
(setq w (cdr w))
`(CASEQ (TYPEP ,(car w))
,.(mapcar #'(lambda (x)
(cons (sublis '((PAIR . LIST)) (car x)) (cdr x)))
(cdr w))))
(macro FIXNUMP (w) `(EQ (TYPEP ,(cadr w)) 'FIXNUM))
)
#+(or LISPM NIL)
(defun |LET.make-list| macro (x) `(MAKE-LIST ,.(cdr x)))
;;; See last page for maclisp's |LET.make-list|
) ;end of temporary macros
;;;; LET decomposer
;;; Following function produces code to perform the decomposition
;;; indicated by the pattern.
(DEFUN |LET.decompose| (PAT VAR USEP)
(AND
PAT
(TYPECASEQ PAT
(SYMBOL `((SETQ ,pat ,var)) ) ;What could be simpler!
(PAIR
(COND ;Here are the simple cases, do one binding to an atom and go on
; destructuring other one. Case of pattern ((...) . <atom>)
((NOT (QSEQUENCEP (CAR PAT)))
(|LET.do-1-atom| 'CAR (CAR PAT) (CDR PAT) VAR USEP))
((NOT (QSEQUENCEP (CDR PAT)))
(|LET.do-1-atom| 'CDR (CDR PAT) (CAR PAT) VAR USEP))
('T ;Complex case, both car,cdr of pattern are non-atomic
;First, see if some non-atomic subform is fake (no vars)
(BIND-LET ((OP))
(COND ((COND ((NOVARS? (CAR PAT))
(SETQ OP 'CAR PAT (CDR PAT))
'T)
((NOVARS? (CDR PAT))
(SETQ OP 'CDR PAT (CAR PAT))
'T))
(|LET.do-1-atom| OP () PAT VAR USEP))
((NCONC (|LET.do-a-subform| 'CAR
(CAR PAT)
VAR
(truthity))
(|LET.do-a-subform| 'CDR
(CDR PAT)
VAR
USEP))))))))
#N ((VECTOR VECTOR-S EXTEND)
(DO ((I 0 (1+ I))
(LN (VECTOR-LENGTH PAT))
(VDCMPL () ) (SUBPAT () ))
((NOT (< I LN)) (NREVERSE VDCMPL))
(AND (SETQ SUBPAT (VREF PAT I))
(TYPECASEQ SUBPAT
(SYMBOL (PUSH `(SETQ ,subpat (VREF ,var ,i)) VDCMPL))
((PAIR VECTOR)
(PUSHNRL (|LET.do-a-subform| I SUBPAT VAR (truthity)) VDCMPL))
(T () )))))
(T () ))))
;;; Come here with an atomic "APAT" (A-pattern), and output a SETQ
;;; corresponding to having taken the "CARCDR" operation over "VAR".
;;; (but no code unless APAT is actually a symbol). Then continue
;;; the decomposing on "DPAT". If DPAT is actually decomposable,
;;; then it corresponds to taking the other "carcdr" operation on "PAT".
;;; "VAR" is the code over which we are taking the car/cdrs, and generally
;;; is some temp variable; but for LISPM style, it *** may someday ** be
;;; compositions like "(CAR (CDR Z))" instead of merely "G0012".
;;; "USEP" non-null means that "VAR" may be used as a temporary variable
;;; during the destructuring of the DPAT part.
(DEFUN |LET.do-1-atom| (CARCDR APAT DPAT VAR USEP)
;Should we think a bit more about selecting a better choice for
; the sub-recursive "VAR" to use as a temp var?
(BIND-LET
((SET-1-VAR (AND (NON-NULL-SYMBOL APAT) `(SETQ ,apat (,carcdr ,var))) )
DCMPL DSYM?)
(COND ((NULL DPAT) () )
((TYPECASEQ DPAT
(SYMBOL (SETQ DSYM? 'T) 'T)
((PAIR #N VECTOR #N VECTOR-S)
(NOT (NOVARS? DPAT))))
;Switch the "carcdr" sense, to do the other half
(SETQ CARCDR (COND ((EQ CARCDR 'CAR) 'CDR) ('CAR)))
(COND ((EQ APAT VAR)
;Lousy case when the variable assignment must be done
; last, due to it being the same as the destructure base
(PUSH SET-1-VAR DCMPL)
(SETQ SET-1-VAR () )
(AND (EQ USEP VAR) (SETQ USEP (truthity)))))
(COND (DSYM? (PUSH `(SETQ ,dpat (,carcdr ,var)) DCMPL))
('T (SETQ DSYM? (|LET.do-a-subform| CARCDR DPAT VAR USEP))
(SETQ DCMPL (NCONC DSYM? DCMPL))))))
(AND SET-1-VAR (PUSH SET-1-VAR DCMPL))
DCMPL))
;;; Only come here when PAT is either a PAIR or VECTOR.
;;; USEP null means we can't use the variable VAR for intermediate temps, and
;;; must get a temporary variable for "optimize"-style destructuring.
;;; these temp vars are in a list, pointed to by the cdr of
;;; |LET.dcmp-tempvars|, so that lambda-binding may shield parts
;;; of the list; we shield over a piece of code in which we don't want
;;; certain variables to be used.
;;; USEP = #T is similar to (), but means test out |LET.gensym-tempvars?|
;;; to determine whether to gensym a new var, or get one from the pattern.
;;; USEP = <symbol> means use that symbol for a temp var.
;This function should really be called |LET.do-a-subform|
(DEFUN |LET.step&decompose| (CARCDR PAT VAR USEP)
(AND (NOT (NOVARS? PAT))
(BIND-LET ((ACCESSOR #-NIL `(,CARCDR ,var)
#+NIL (COND ((FIXNUMP CARCDR)
`(VREF ,var ,carcdr))
(`(,CARCDR ,var)))
))
(COND ((OR (NULL USEP)
(AND (EQ USEP (truthity)) |LET.gensym-tempvars?|))
(COND ((NULL |LET.dcmp-tempvars|) (ERROR '|LET.do-a-subform|))
((NULL (CDR |LET.dcmp-tempvars|))
(RPLACD |LET.dcmp-tempvars| (LIST (GENSYM)))))
(BIND-LET ((|LET.dcmp-tempvars| |LET.dcmp-tempvars|))
(SETQ VAR (CADR |LET.dcmp-tempvars|))
(POP |LET.dcmp-tempvars|)
`((SETQ ,var ,accessor)
,. (|LET.decompose| pat var var))))
((COND ((EQ USEP (truthity))
(NULL (SETQ VAR (|LET.find-rightmost| PAT))))
(USEP (NOT (EQ USEP VAR)))
('T))
(ERROR '|LET.do-a-subform| PAT))
('T `((SETQ ,var ,accessor)
,. (|LET.decompose| pat var usep)) )))))
;;;; |LET.match-vars|
;;; This foolish function ought to be in the system!
;;; If "|LET.matchp|" is null, then simply search for any variable
;;; going in the specified direction. If |LET.direction| is +1,
;;; then go in the "CAR" direction, ie left-to-right in print order;
;;; if -1, then in the "CAR", or right-to-left, direciton.
;;; If "|LET.matchp|" is #T, then list all variables in the pattern, by
;;; pushing onto the fourth argument; otherwise,
;;; If "|LET.matchp|" is non-null, then search for occurrence
;;; of that particular variable.
;;; Returns null if there aren't any variables in the pattern;
;;; otherwise, returns variable which satisfies "|LET.matchp|".
(DEFUN |LET.match-vars| (|LET.matchp| PAT |LET.direction| |LET.listallvars|)
(DECLARE (SPECIAL |LET.matchp| |LET.direction| |LET.listallvars|))
(|LET.anyvarsp| PAT))
(DEFUN |LET.anyvarsp| (PAT)
(DECLARE (SPECIAL |LET.matchp| |LET.direction| |LET.listallvars|)
(FIXNUM |LET.direction|))
(AND PAT
(TYPECASEQ PAT
(SYMBOL (COND ((OR (NULL |LET.matchp|) (EQ |LET.matchp| PAT))
PAT)
((EQ |LET.matchp| (truthity))
(PUSH PAT |LET.listallvars|)
|LET.listallvars|)))
#+NIL (VECTOR
(PROG (LN IX TMP)
(DECLARE (FIXNUM LN IX))
(SETQ LN (VECTOR-LENGTH PAT)
IX (COND ((= |LET.direction| -1) (1- LN))
('T 0)))
TG (AND (= 0 LN)
(RETURN (AND (EQ |LET.matchp| (truthity))
|LET.listallvars|)))
(AND (SETQ TMP (|LET.anyvarsp| (VREF PAT IX)))
(NOT (EQ |LET.matchp| (truthity)))
(RETURN TMP))
(SETQ IX (+ |LET.direction| IX) LN (1- LN))
(GO TG)))
(PAIR (COND ((EQ |LET.matchp| (truthity))
(COND ((= |LET.direction| -1)
(|LET.anyvarsp| (CDR PAT))
(|LET.anyvarsp| (CAR PAT)))
('T (|LET.anyvarsp| (CAR PAT))
(|LET.anyvarsp| (CDR PAT))))
|LET.listallvars|)
((= |LET.direction| -1)
(OR (|LET.anyvarsp| (CDR PAT))
(|LET.anyvarsp| (CAR PAT))))
((OR (|LET.anyvarsp| (CAR PAT))
(|LET.anyvarsp| (CDR PAT) )))))
(T () ))))
;;;; LET and LET* Expanders
(DEFUN LET-expander-1 (L)
(PROG (LETL LMBODY |LET.dcmp-tempvars| VARS VALS EXCEPTIONS
GVAR DECLP DCMPL LL OK-FL ALLFLATS NVAR NVAL)
(SETQ LETL (CAR L) LMBODY (CDR L))
(SETQ |LET.dcmp-tempvars| (LIST () ) OK-FL 'T)
(COND ((AND (NOT (ATOM (CAR LMBODY))) (EQ (CAAR LMBODY) 'DECLARE))
(SETQ DECLP (LIST (CAR LMBODY)))
(POP LMBODY)))
(IF (NULL LMBODY) ;If you ask me [JonL - 12/1/80]
(PUSH () LMBODY)) ; (LAMBDA (...)) should be a bug
(MAPC
#'(LAMBDA (IL)
(SETQ NVAR () NVAL () LL () )
(COND
((NOT OK-FL))
((NULL IL) (SETQ OK-FL () ))
((TYPECASEQ IL
(SYMBOL (SETQ NVAR IL))
(PAIR
(COND
((AND (NOT (ATOM (CDR IL)))
(CDDR IL))
(SETQ OK-FL () ))
((NULL (CAR IL))
(setq nvar ()
nval (macroexpand (cadr il)))
(and (or (not (pairp nval))
(eq (car nval) 'QUOTE))
(setq nval () )))
((TYPECASEQ (CAR IL)
(SYMBOL (SETQ NVAR (CAR IL) NVAL (CADR IL)) )
((PAIR #N VECTOR #N VECTOR-S)
(SETQ ALLFLATS (|LET.listallvars| (CAR IL) ALLFLATS))
(COND ((COND ((NULL (CADR IL)) () )
((NULL |LET.gensym-tempvars?|)
(SETQ GVAR (|LET.find-rightmost| (CAR IL)))
(PUSH GVAR EXCEPTIONS)
'T)
((AND #N (PAIRP (CAR IL))
(SYMBOLP (CAAR IL))
(NOVARS? (CDAR IL)))
(PUSH (SETQ GVAR (CAAR IL)) VARS)
(PUSH `(CAR ,(cadr il)) VALS)
(PUSH GVAR EXCEPTIONS)
() )
('T (SETQ GVAR (GENSYM)) 'T))
(SETQ LL (|LET.decompose| (CAR IL) GVAR GVAR))
(SETQ NVAR (AND LL GVAR) NVAL (CADR IL)))))
(T (SETQ OK-FL () ))))))
(T (SETQ OK-FL () )))))
(COND (OK-FL (PUSH NVAR VARS)
(PUSH NVAL VALS)
(AND LL (SETQ DCMPL (NCONC LL DCMPL))))))
LETL)
(AND (OR (NOT OK-FL) (|LET.repeated?| ALLFLATS))
(ERROR "Bad variable list in LET" LETL))
(SETQ DCMPL (|LET.optimize| DCMPL ALLFLATS)) ;POPs tempvars also
(AND EXCEPTIONS
(MAPC #'(LAMBDA (X) (SETQ ALLFLATS (DELQ X ALLFLATS)))
EXCEPTIONS))
(SETQ ALLFLATS (NCONC |LET.dcmp-tempvars| ALLFLATS))
(SETQ VARS (NRECONC VARS ALLFLATS)
VALS (NRECONC VALS (|LET.make-list| (LENGTH ALLFLATS))))
(RETURN `((LAMBDA ,vars
,.declp
,.(nconc dcmpl lmbody))
,.vals))))
(DEFUN LET*-expander-1 (L)
(LET-expander-1
(COND ((OR (ATOM (CAR L)) (ATOM (CDAR L))) L)
((BIND-LET ((LMBODY (CDR L)) DECLP)
(COND ((AND (NOT (ATOM (CAR LMBODY)))
(EQ (CAAR LMBODY) 'DECLARE))
(SETQ DECLP (CAR LMBODY))
(SETQ LMBODY (CDR LMBODY))))
(IF (NULL LMBODY) ;If you ask me [JonL - 12/1/80]
(PUSH () LMBODY)) ; (LAMBDA (...)) should be a bug
(PUSH 'PROGN LMBODY)
(MAPC #'(LAMBDA (BND) (SETQ LMBODY `(LET (,bnd) ,lmbody)))
(REVERSE (CAR L)))
(COND (DECLP `(,(cadr lmbody) ,declp ,. (cddr lmbody)))
('T (CDR LMBODY))))))))
;;;; DESETQ Expander
(DEFUN DESETQ-expander-1 (LL)
(PROG (L DCMPL GVAR GVAR-INIT ITEM PAT DS-VAR ALLFLATS VARS
|LET.dcmp-tempvars| TMP-VAR)
(SETQ L LL |LET.dcmp-tempvars| (LIST () ))
LOOP-START
(AND (NOT (PAIRP L)) (GO EXIT))
(AND (NOT (PAIRP (CDR L))) (GO BAD))
(SETQ PAT (CAR L) ITEM (CADR L))
;; Following code weeds out all but the complex patterns
#+BadNULL
(AND (NULL PAT) (GO FLUSH-1))
(TYPECASEQ PAT
(PAIR () )
(SYMBOL (PUSH `(SETQ ,pat ,item) DCMPL)
(GO LOOP-CYCLE))
#N (CONSTANT (GO FLUSH-1))
#+NIL (VECTOR (TYPECASEQ ITEM
((PAIR SYMBOL) () )
(VECTOR
(AND (< (VECTOR-LENGTH ITEM) (VECTOR-LENGTH PAT))
(GO BAD)))
(T (GO BAD))))
(T (GO BAD)) )
;Fall thru here only if PAT is a PAIR or VECTOR
(AND (NOVARS? PAT) (GO FLUSH-1))
;So now we have a valid pattern
#+BadNULL
(AND (NULL ITEM) (GO NILLS))
(TYPECASEQ ITEM
(SYMBOL (COND ((OR (EQ ITEM (CAR PAT))
;Like "(DESETQ (A ...) A)"; can use A as temp
(EQ ITEM (SETQ DS-VAR (|LET.find-rightmost| PAT)))
;Like "(DESETQ (... B) B)"; can use B as temp
)
(SETQ TMP-VAR (SETQ DS-VAR ITEM))
(GO DCMP-DS-VAR))
((OR (NOT |LET.gensym-tempvars?|) (SETQ DS-VAR GVAR))
;DS-VAR, if not GVAR, is from |LET.find-righmost|
(GO SET-DS-VAR-PUSH))
((NOT (|LET.in-pattern?| ITEM PAT))
(SETQ DS-VAR ITEM TMP-VAR ())
(GO DCMP-DS-VAR))
;Fall thru to case of set GVAR to gensym
('T () )))
;Normal destructuring, e.g. (desetq (f g h) (mumble 3))
(PAIR () )
#+NIL (CONSTANT (GO NILLS))
(T (GO BAD)))
;LISTs, and some cases of SYMBOLs, fall thru to here
;Get a variable over which to destructure.
(SETQ DS-VAR (COND (GVAR)
(|LET.gensym-tempvars?| (SETQ GVAR (GENSYM)))
('T (|LET.find-rightmost| PAT))))
SET-DS-VAR-PUSH
(PUSH `(SETQ ,DS-VAR ,item) DCMPL)
(SETQ TMP-VAR DS-VAR)
DCMP-DS-VAR
(PUSHNRL (|LET.decompose| PAT DS-VAR TMP-VAR) DCMPL)
LOOP-CYCLE
(SETQ VARS (|LET.listallvars| PAT () ))
(AND (|LET.repeated?| VARS) (GO BAD))
(SETQ ALLFLATS (NCONC VARS ALLFLATS))
(SETQ L (CDDR L))
(GO LOOP-START)
FLUSH-1 ;If pattern null, then just eval item
(PUSH `(PROG2 () ,item) DCMPL) ;possibly for side-effects
(SETQ PAT () )
(GO LOOP-CYCLE)
NILLS
(MAPC #'(LAMBDA (X) (PUSH `(SETQ ,x () ) DCMPL)) ;bind a bunch of
(SETQ PAT (|LET.listallvars| PAT () ))) ; variables to ()
(GO LOOP-CYCLE)
EXIT
(SETQ DCMPL (NREVERSE DCMPL))
(RETURN
(COND ((COND ((NULL GVAR)
(SETQ DCMPL (|LET.optimize| DCMPL ALLFLATS))
(NULL |LET.dcmp-tempvars|)))
`(PROGN ,. dcmpl))
('T (AND GVAR
(SETQ GVAR-INIT `((,gvar ,(and (eq (caar dcmpl) 'SETQ)
(eq (cadar dcmpl) gvar)
(null (cdddar dcmpl))
(prog2 ()
(caddar dcmpl)
(pop dcmpl) ))))
DCMPL (|LET.optimize| DCMPL ALLFLATS)))
`(LET (,.gvar-init ,. |LET.dcmp-tempvars|)
,. dcmpl) )))
BAD (ERROR "Bad form to DESETQ" `(DESETQ ,pat ,item))
))
;;;; |LET.optimize|
;;; A post-optimization phase which converts
;;; (...(SETQ G (CAR <x>)) (SETQ G (CDR G)) ...)
;;; into
;;; (... (SETQ G (CDR (CAR <x>))) ...)
(DEFUN |LET.optimize| (DCMPL ALLPATS)
(PROG (THIS-VAR NEXT-VAR NEXT-CAR THIS-CAR DDL)
(SETQ DCMPL (CONS () DCMPL))
(DO ((L DCMPL))
((NULL (SETQ DDL (CDDR L))) () )
;(DESETQ (() ;Compose certain two
; (() THIS-VAR THIS-CAR) ; adjacent SETQ's by
; (() NEXT-VAR NEXT-CAR)) ; "splicing out" one
; L)
(SETQ THIS-CAR (CDADR L) NEXT-CAR (CDAR DDL)) ;See how much better
(AND (OR (ATOM THIS-CAR) (ATOM NEXT-CAR)) ; this would be if it
(ERROR '|LET.optimize| DCMPL)) ; were a DESETQ!
(SETQ THIS-VAR (CAR THIS-CAR) NEXT-VAR (CAR NEXT-CAR))
(SETQ THIS-CAR (CADR THIS-CAR) NEXT-CAR (CADR NEXT-CAR))
(COND ((AND (EQ THIS-VAR (CADR NEXT-CAR)) ;requires unoptimized
(OR (EQ THIS-VAR NEXT-VAR)
(DO ((Z (CDR DDL) (CDR Z)))
((NULL Z)
;Var not referenced in DCMPL, but ? in PAT ?
(NOT (|LET.in-pattern?| THIS-VAR ALLPATS)))
(COND ((|LET.in-pattern?| THIS-VAR (CADDAR Z))
;Var being "used"
(RETURN () ))
((EQ THIS-VAR (CADAR Z))
;Var is being SETQ'd so previous value
(RETURN 'T)))))) ;not needed
(SETQ THIS-CAR `(,(car next-car) ,(caddr (cadr l))
,. (cddr next-car)))
(RPLACD L `((SETQ ,next-var ,this-car) ,. (cdr ddl))))
('T (POP L))))
(DO ((L |LET.dcmp-tempvars|))
((NULL (CDR L)) () ) ;Splice out of tempvars
(SETQ THIS-VAR (CADR L)) ; any unused ones
(COND ((DOMAP-OR (L DCMPL)
(OR ;((SETQ <v> #) ...)
(EQ THIS-VAR (CADAR L))
;((SETQ # <carcdrings>) ...)
(|LET.in-pattern?| THIS-VAR (CADDAR L))))
(POP L))
('T (RPLACD L (CDDR L)))))
(POP |LET.dcmp-tempvars|) ;Flush vacuuous NIL at
(POP DCMPL) ; head of lists
(RETURN DCMPL)))
;;;; Macro definitions
#-NIL (progn 'compile
#M (progn 'compile
(defun |LET.make-list| (ln)
(do ((i ln (1- i)) (zz () (cons () zz)))
((zerop i) zz)))
(and (eq (sysp 'MAKE-LIST) 'SUBR)
(putprop '|LET.make-list| (get 'MAKE-LIST 'SUBR) 'SUBR))
(or (getl 'FLUSH-MACROMEMOS '(SUBR AUTOLOAD))
(DEFPROP FLUSH-MACROMEMOS ((LISP) DEFMAX) AUTOLOAD))
)
#Q (or (fboundp 'FLUSH-MACROMEMOS)
(get 'FLUSH-MACROMEMOS 'AUTOLOAD)
(defprop FLUSH-MACROMEMOS "LISP;DEFMAX" AUTOLOAD))
(eval-when (eval compile)
(SETQ DEFMACRO-DISPLACE-CALL 'T
DEFMACRO-FOR-COMPILING MACROEXPANDED
DEFMACRO-CHECK-ARGS () )
)
(DEFMACRO DESETQ (&REST L) (DESETQ-expander-1 L))
(DEFMACRO LET* (&REST L) (LET*-expander-1 L))
;;; WAIT! You loser, don't move this macro definition. It should be
;;; at the end, so that the previous LET will be active during
;;; compilation.
(DEFMACRO LET (&REST L) (LET-expander-1 L))
)

1605
src/nilcom/string.186 Executable file
View File

File diff suppressed because it is too large Load Diff

356
src/nilcom/vsaid.57 Normal file
View File

@@ -0,0 +1,356 @@
;;; VSAID -*-MODE:LISP;PACKAGE:SI-*- -*-LISP-*-
;;; **************************************************************
;;; *** MACLISP ******* Aid to MACLISP for VECTORs ***************
;;; **************************************************************
;;; ** (C) COPYRIGHT 1980 MASSACHUSETTS INSTITUTE OF TECHNOLOGY **
;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) *******
;;; **************************************************************
;;; See second page for commentary
(eval-when (eval compile)
(or (status nofeature MACLISP)
(status macro /#)
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))
(and (status feature MACLISP)
(status nofeature MULTICS)
(sstatus feature PDP10))
)
(eval-when (eval compile)
(and (status nofeature MACAID) (load '((LISP) MACAID)))
)
#Q (globalize "PTR-TYPEP" "PAIRP" "LISTP" "SEQUENCEP" "MAKE-LIST"
"TYPECASEQ" "MAKE-VECTOR" "VECTOR" "VECTORP" "VREF"
"VSET" "VECTOR-LENGTH" "REPLACE" "SUBSEQ" "ELT"
"SETELT" "SYMBOLCONC" "NIL-INTERN"
)
(herald VSAID /57)
(eval-when (load)
(and #-LISPM
(status feature COMPLR)
(special |+internal-VECTOR-class-object/||
|+internal-EXTEND-class-object/||
|+internal-CLASS-class-object/|| ))
)
(eval-when (compile)
(and (status nofeature VSAID) (load '((LISP) VSAID)))
)
(declare (/@define defsimplemac defbothmacro))
;;; VECTOR primitive support routines which help NILAID and DEFVST
;;; A sequence of length "n" is translated into a hunk of size "n+2"
;;; where the 1st element is the symbolic data type. (0th for CLASSes).
;;; On LISPM, they translate into ART-Qs of 1 dimension.
;;; Primitive data-type support:
;;; PTR-TYPEP, PAIRP, LISTP, SEQUENCEP, MAKE-LIST, TYPECASEQ (as a macro)
;;; VECTOR support macros:
;;; MAKE-VECTOR, VECTOR, VECTORP, VREF, VSET, VECTOR-LENGTH,
;;; Misc support functions:
;;; REPLACE, SUBSEQ, ELT, SETELT, SYMBOLCONC,
;;; Also, all the MACAID file is loaded in, for some macro-expansion support:
;;; DEFSIMPLEMAC, DEFBOTHMACRO, |constant-p/||, |no-funp/||,
;;; |carcdrp/|| |side-effectsp/||
;;; Here's some particular macro definitions and declaractions,
;;; knowing that the intended target is with the other maclisp
;;; NILCOM software.
#M (declare (*LEXPR STRING-REPLACE STRING-SUBSEQ STRING-MISMATCHQ
SYMBOLCONC )
(*EXPR PTR-TYPEP MAKE-STRING STRING-PNGET
CHAR CHAR-N RPLACHAR RPLACHAR-N STRING-LENGTH)
(FIXNUM (CHAR-N () FIXNUM))
(NOTYPE (RPLACHAR-N () FIXNUM FIXNUM)))
#M (defun |index+2-examine/|| (H N)
(cond ((|constant-p/|| N)
(cond ((fixp N) (+ 2 N))
((and (not (atom N)) (eq (car N) 'QUOTE) (fixp (cadr N)))
(+ 2 (cadr N)))
('t `(+ 2 ,n))))
((OR (|constant-p/|| H)
(AND (NOT (|side-effectsp/|| N))
(NOT (|side-effectsp/|| H))))
`(+ 2 ,n))))
;;; What a gross shaft ensues if you try to uses the MACROEXPANDED
;;; memoizing feature with this macro, **SELF-EVAL**!
#M (macro **SELF-EVAL** (x) `(QUOTE ,x))
(comment initial CLASS stuff)
; This is merely an internal helper function
#+PDP10
(progn 'compile
(declare (setq defmacro-check-args () ))
(defmacro *:EXTEND (class &rest data)
`(HUNK '**SELF-EVAL** ,@data ,class))
(defcomplrmac |cons-a-NEWdtp| (type &rest data)
(or (memq type '(STRING CLASS VECTOR CHARACTER BITS))
(error '|what the heck? - cons-a-NEWdtp| type))
(cond ((eq type 'CLASS)
(setq data `(,(car data) () () () () ()))))
`(*:EXTEND ,(intern (symbolconc '|+internal-| type '|-class-object/||))
,.data))
(defmacro *:CLASS-OF (ob) `(CDR ,ob))
(defun CLASS-OF (ob) ;; Called by SENDI. Must be fast.
(declare (special *:PRIMITIVE-TYPES-CLASS-TABLE))
(cond ((hunkp ob) (*:class-of ob))
('t (error '|CLASS-OF doesn't work on non-EXTENDs!| ob 'fail-act))))
(defmacro *:CLASS-TYPEP (class) `(CXR 2 ,class))
(defmacro *:CLASS-SUPRS (class) `(CXR 3 ,class))
(defmacro *:CLASS-SENDI (class) `(CXR 4 ,class))
(defmacro *:CLASS-CALLI (class) `(CXR 5 ,class))
(defmacro *:CLASS-METHODS (class) `(CXR 6 ,class))
(defmacro *:CLASS-DESCR (class) `(CXR 7 ,class))
;CLASSES have 6 significant components [the car and cdr are respectively
; forced to be **SELF-EVAL** and the super-class marker]
(defcomplrmac *:CLASSP (item &aux (y (gensym)))
`(LET ((,y ,item))
(COND ((OR (NOT (HUNKP ,y))
(NOT (EQ (CAR ,y) '**SELF-EVAL**))
(< (VECTOR-LENGTH ,y) 6))
() )
((OR (EQ (SETQ ,y (*:CLASS-OF ,y))
|+internal-CLASS-class-object/||)
(EQ ,y '|CLASS-of-CLASSES: The BUCK stops here!/||))
'T)
;The following several lines constitute an open-coding of
; (EQUAL (cddr item) |+internal-CLASS-class-object/||)
((OR (NOT (HUNKP ,y))
(NOT (EQ (CAR ,y) '**SELF-EVAL**))
(< (VECTOR-LENGTH ,y) 6))
() )
((AND (EQ (*:CLASS-TYPEP ,y) 'CLASS)
(EQ (*:CLASS-OF ,y)
'|CLASS-of-CLASSES: The BUCK stops here!/||))
'T))))
)
;;; ########## MULTICS NEWdtp ?
#-PDP10
(progn 'compile
#+MULTICS
(progn 'compile
(defcomplrmac AR-1 (&rest w) `(ARRAYCALL T ,.w))
(defcomplrmac AS-1 (val &rest w) `(STORE (ARRAYCALL T ,.w) ,val))
)
(defmacro |cons-a-NEWdtp| (type &rest data)
(or (memq type '(STRING CLASS VECTOR CHARACTER BITS))
(error '|what the heck? - cons-a-NEWdtp| type))
`(|Fill-NEWdtp| ,(intern (string-append "+internal-"
(string type)
"-class-object/|"))
,. data))
(defun |Fill-NEWdtp| (type &rest data)
(do ((h (make-array () 'ART-Q (1+ (length data))))
(i 1 (1+ i)))
((null x)
(as-1 type h 0)
h)
(as-1 (car x) h i)))
)
; Here comes the original bootstrap for the CLASS system!
(SETQ |+internal-CLASS-class-object/|| ()
|+internal-CLASS-class-object/|| (|cons-a-NEWdtp| CLASS 'CLASS))
#+PDP10 (rplacx 0
|+internal-CLASS-class-object/||
'|CLASS-of-CLASSES: The BUCK stops here!/||)
#-PDP10 (as-1 '|CLASS-of-CLASSES: The BUCK stops here!/||
|+internal-CLASS-class-object/||
0)
(SETQ |+internal-VECTOR-class-object/|| (|cons-a-NEWdtp| CLASS 'VECTOR))
(comment PTR-TYPEP and type macros)
(defun PTR-TYPEP (x)
(cond ((null x) 'CONSTANT)
#+PDP10 ((hunkp x)
(cond ((and (eq (car x) '**SELF-EVAL**)
(*:classp (*:class-of x)))
(or (car (memq (*:class-typep (*:class-of x))
'(STRING CHARACTER VECTOR BITS
CONSTANT SUBR SMALL-FLONUM)))
'EXTEND))
((and (eq (car x) '**SELF-EVAL**)
(eq (cdr x) '|CLASS-of-CLASSES: The BUCK stops here!/||))
'EXTEND)
('t 'HUNK)))
((let ((typ (typep x)))
(cond ((eq typ 'LIST) 'PAIR)
#Q ((and (eq typ 'ARRAY)
(eq (array-type x) 'ART-Q)
(= (array-/#-dims x) 1))
(setq typ (ar-1 x 0))
(cond ((and (arrayp typ)
(eq (array-type typ) 'ART-Q)
(= (array-/#-dims typ) 1)
(cond ((eq (ar-1 typ 0) |+internal-CLASS-class-object/||))
((eq (ar-1 typ 0) '|CLASS-of-CLASSES: The BUCK stops here!/||))
;The following is an open-coding of
; (EQUAL (ar-1 typ 0) |+internal-CLASS-class-object/||)
((and (arrayp (ar-1 typ 0))
(eq (array-tyep (ar-1 typ 0)) 'ART-Q)
(= (array-/#-dims (ar-1 typ 0)) 1)
(eq (ar-1 (ar-1 typ 0) 0)
'|CLASS-of-CLASSES: The BUCK stops here!/||)
(eq (ar-1 (ar-1 typ 0) 1) 'CLASS)))))
(ar-1 typ 1))
('ARRAY)))
#+MULTICS ((eq typ 'ARRAY) (error '|not yet coded - PTR-TYPEP|))
((eq typ 'BIGNUM) 'EXTEND)
('t typ))))))
(defmacro TYPECASEQ (x &rest y) `(CASEQ (PTR-TYPEP ,x) ,@y))
(defbothmacro PAIRP (x) `(EQ (TYPEP ,x) 'LIST))
(defbothmacro VECTORP (x) `(EQ (PTR-TYPEP ,x) 'VECTOR))
(defbothmacro LISTP simple (x)
`(OR (NULL ,x)
(EQ (TYPEP ,x) 'LIST)))
(defbothmacro SEQUENCEP simple (x)
`(OR (NULL ,x)
(AND (MEMQ (PTR-TYPEP ,x)
'(PAIR STRING VECTOR VECTOR-S EXTEND BITS)) 'T)))
(comment VECTOR primitives)
#+PDP10
(progn 'compile
(defbothmacro VECTOR-LENGTH (x) `(- (HUNKSIZE ,x) 2))
(defbothmacro VREF (h n)
(let ((tmp (|index+2-examine/|| h n)) htem)
(cond (tmp `(CXR ,tmp ,h))
('T (setq htem (gensym) tmp (gensym))
`((LAMBDA (,htem ,tmp)
(CXR (+ 2 ,tmp) ,htem))
,h ,n)))))
(defbothmacro VSET (h n val)
(let ((tmp (|index+2-examine/|| h n)) htem)
(cond (tmp `(RPLACX ,tmp ,h ,val))
('T (setq htem (gensym) tmp (gensym))
`((LAMBDA (,htem ,tmp)
(RPLACX (+ 2 ,tmp) ,htem ,val))
,h ,n)))))
(defbothmacro *:MAKE-EXTEND (n cl)
(let ((v (gensym)))
`(LET ((,v (MAKHUNK (+ ,n 2))))
(RPLACX 0 ,v ,cl)
(RPLACX 1 ,v '**SELF-EVAL** ))))
) ;end of #M
#-PDP10
(progn 'compile
(defbothmacro VECTOR-LENGTH (x) `(- (ARRAY-DIMENSION-N 1 ,x) 1))
(defbothmacro VREF (h n) `(AR-1 ,h (1+ ,n)))
(defbothmacro VSET (h n val)
(cond ((or (|side-effectsp/|| h)
(|side-effectsp/|| n)
(|side-effectsp/|| val))
(let ((htem (gensym)) (tmp (gensym)))
`((LAMBDA (,htem ,tmp) (AS-1 ,val ,htem (1+ ,tmp)))
,h ,n)))
(`(AS-1 ,val ,h (1+ ,n)))))
(defbothmacro *:MAKE-EXTEND (n cl)
(let ((v (gensym)))
`(LET ((,v (MAKE-ARRAY () 'ART-Q (1+ ,n))))
(AS-1 ,cl ,v 0)
,v)))
) ;end of #Q
(defbothmacro MAKE-VECTOR (n)
`(*:MAKE-EXTEND ,n |+internal-VECTOR-class-object/||))
(defun VECTOR #M n #Q (&rest x &aux (n (length x)))
(declare (fixnum n))
(cond ((= n 0) () )
('t (do ((v (make-vector n))
#Q (l x (cdr l))
(i 0 (1+ i)))
((not (< i n)) v)
(vset v i #M (arg (1+ i)) #Q (car l))))))
(comment MAKE-LIST ELT SYMBOLCONC)
(defun MAKE-LIST (count)
(do ((l () (cons () l)) (n count (1- n)))
((< n 1) l)
(declare (fixnum n))))
(DEFUN ELT (V I)
(DECLARE (FIXNUM I))
(TYPECASEQ V
(PAIR (NTH I V))
(VECTOR (VREF V I))
(STRING (CHAR V I))
(BITS (BIT V I))
(T (ELT (ERROR V '|Sequence is required - ELT| 'WRNG-TYPE-ARG) I))))
(DEFUN SETELT (V I X)
(DECLARE (FIXNUM I))
(TYPECASEQ V
(PAIR (RPLACA (NTHCDR I V) X))
(VECTOR (VSET V I X))
(STRING (RPLACHAR V I X))
(BITS (RPLACBIT V I X))
(T (SETELT (ERROR V '|Sequence is required - SETELT| 'WRNG-TYPE-ARG)
I
X))))
(DEFUN SYMBOLCONC N
(DECLARE (FIXNUM I J LN N))
(DO ((I 1 (1+ I)) (LN 0) (ANS) (TYP) (A))
((> I N) (IMPLODE (NREVERSE ANS)))
(COND ((COND ((EQ (SETQ TYP (TYPEP (SETQ A (ARG I)))) 'SYMBOL)
(SETQ A (EXPLODEN A))
'T)
((EQ TYP 'LIST) (SETQ A (APPEND A () )) 'T))
(SETQ ANS (NRECONC A ANS)))
((HUNKP A)
(COND ((COND ((EQ (SETQ TYP (PTR-TYPEP A)) 'STRING)
(SETQ LN (STRING-LENGTH A))
'T)
((MEMQ TYP '(VECTOR VECTOR-S))
(SETQ LN (VECTOR-LENGTH A))
'T))
(DO ((J 0 (1+ J)))
((NOT (< J LN)))
(PUSH (COND ((EQ TYP 'VECTOR) (VREF A J))
('T (CHAR-N A J)))
ANS)))
('T (ERROR '|BAD ARG - SYMBOLCONC| A)))))))
#M (progn 'compile
(DEFPROP STRING-PNGET ((LISP) STRING FASL) AUTOLOAD)
(mapc '(lambda (x) (putprop x '((LISP) SUBSEQ FASL) 'AUTOLOAD))
'(REPLACE SUBSEQ TO-LIST TO-VECTOR))
)
(SSTATUS FEATURE VSAID)