From a92bc9d8dae1e8d5bcf98430c5be69c3ed7e08a6 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Wed, 3 Oct 2018 19:44:38 -0700 Subject: [PATCH] Updated to remaining lisp; fasl files from source. Resolves #1286. --- build/lisp.tcl | 35 +- src/lspsrc/exthuk.34 | 121 ++++ src/lspsrc/extmdf.29 | 49 ++ src/lspsrc/gcdemn.14 | 307 +++++++++ src/lspsrc/gfile.422 | 335 ++++++++++ src/lspsrc/gfn.462 | 1520 ++++++++++++++++++++++++++++++++++++++++++ src/lspsrc/querio.51 | 213 ++++++ src/lspsrc/sendi.107 | 297 +++++++++ src/lspsrc/straux.74 | 1260 ++++++++++++++++++++++++++++++++++ src/lspsrc/vector.75 | 324 +++++++++ src/nilcom/cnvd.2 | 138 ++++ 11 files changed, 4596 insertions(+), 3 deletions(-) create mode 100755 src/lspsrc/exthuk.34 create mode 100755 src/lspsrc/extmdf.29 create mode 100755 src/lspsrc/gcdemn.14 create mode 100755 src/lspsrc/gfile.422 create mode 100755 src/lspsrc/gfn.462 create mode 100755 src/lspsrc/querio.51 create mode 100755 src/lspsrc/sendi.107 create mode 100755 src/lspsrc/straux.74 create mode 100755 src/lspsrc/vector.75 create mode 100755 src/nilcom/cnvd.2 diff --git a/build/lisp.tcl b/build/lisp.tcl index b7f1989c..d1bcd60b 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -124,7 +124,7 @@ type ":kill\r" respond "*" ":link l;humble fasl,lisp;\r" respond "*" ":link l;ledit* fasl,lisp;\r" -respond "*" ":link l;let fasl,lisp\r" +respond "*" ":link l;let fasl,lisp;\r" respond "*" "complr\013" respond "_" "lisp;_nilcom;macaid\r" @@ -735,7 +735,7 @@ type ":kill\r" respond "*" "complr\013" respond "_" "liblsp;_libdoc;for\r" -respond "_" "liblsp;_libdoc;gcdemn\r" +respond "_" "lisp;_lspsrc;gcdemn\r" respond "_" "liblsp;_libdoc;genfns\r" respond "_" "liblsp;_libdoc;graphs\r" respond "_" "liblsp;_libdoc;graphm\r" @@ -750,6 +750,9 @@ respond "_" "liblsp;_libdoc;linere\r" respond "_" "\032" type ":kill\r" +respond "*" ":delete libdoc;gcdemn 999999\r" +respond "*" ":link libdoc;gcdemn 999999,lspsrc;gcdemn >\r" + respond "*" "complr\013" respond "_" "liblsp;_libdoc;loop\r" respond "_" "liblsp;_libdoc;more\r" @@ -829,7 +832,7 @@ respond "*" ":delete liblsp;filbit unfasl\r" respond "*" ":delete liblsp;fload unfasl\r" respond "*" ":delete liblsp;fontrd unfasl\r" respond "*" ":delete liblsp;for unfasl\r" -respond "*" ":delete liblsp;gcdemn unfasl\r" +respond "*" ":delete lisp;gcdemn unfasl\r" respond "*" ":delete liblsp;genfns unfasl\r" respond "*" ":delete liblsp;gprint unfasl\r" respond "*" ":delete liblsp;graph$ unfasl\r" @@ -1009,6 +1012,32 @@ respond "_" "lisp;_nilcom;defset\r" respond "_" "\032" type ":kill\r" +# compile some lisp; libraries +respond "*" "complr\013" +respond "_" "lisp;_nilcom;cnvd\r" +respond "_" "lisp;_lspsrc;exthuk\r" +respond "_" "lisp;_lspsrc;gfile\r" +respond "_" "lisp;_lspsrc;gfn\r" +respond "_" "\032" +type ":kill\r" + +respond "*" "complr\013" +respond "_" "lisp;_lspsrc;querio\r" +respond "_" "lisp;_lspsrc;vector\r" +respond "_" "\032" +type ":kill\r" + +respond "*" ":midas lisp;_lspsrc;sendi\r" +expect ":KILL" +respond "*" ":midas lisp;_lspsrc;straux\r" +expect ":KILL" + +# lispt source is in libdoc, therefore fasl should be in liblsp +# version in lisp; should be a link to liblsp;lispf fasl +respond "*" ":delete lisp;lispt fasl\r" +respond "*" ":link lisp;lispt fasl,liblsp;\r" +respond "*" ":link sys2;ts lispt,sys2;ts edit\r" + # Lisp display library respond "*" ":midas lisp; slave fasl_l; slave\r" expect ":KILL" diff --git a/src/lspsrc/exthuk.34 b/src/lspsrc/exthuk.34 new file mode 100755 index 00000000..cf9401cb --- /dev/null +++ b/src/lspsrc/exthuk.34 @@ -0,0 +1,121 @@ +;;; EXTHUK -*-Mode:Lisp;Package:SI;Lowercase:T-*- +;;; **************************************************************** +;;; *** MACLISP **** EXTended datatype scheme, compiler helper ***** +;;; **************************************************************** +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **** +;;; **************************************************************** + +(herald EXTHUK /33) + +(eval-when (eval compile) + (or (get 'SUBLOAD 'VERSION) + (load '((lisp) subload))) + (subload EXTMAC) + ) + +(declare #.`(SPECIAL ,.si:extstr-setup-classes)) + +(defvar SI:SKELETAL-CLASSES () "At least it wont be unbound in Old lisps") + +(declare (own-symbol SI:XREF SI:XSET SI:EXTEND-LENGTH + SI:EXTEND SI:MAKE-EXTEND)) + + + +(eval-when (eval compile load) + ;;COMPLR should already have MACAID pre-loaded +(defun SI:INDEX+2-EXAMINE (h n &aux cnstntp) + ;;A helper function for running the SI:XREF/SI:XSET macroexpansions + ;;Presumes that arguments 'h' and 'n' have already been macroexpanded + ;;Also needs the function 'si:evaluate-number?' from SRCTRN file + (cond ((setq cnstntp (si:evaluate-number? n)) + ;;Constant numerical index + (+ #.si:extend-q-overhead cnstntp)) + ((or (|constant-p/|| h) + (and (not (|side-effectsp/|| n)) + (not (|side-effectsp/|| h)))) + `(+ #.si:extend-q-overhead ,n)))) +) + +(defun SI:XSTUFF-expander (x) + (values + (caseq (car x) + ((SI:XREF SI:XSET) + (if (< (length x) (if (eq (car x) 'SI:XREF) 3 4)) + (error "Wrong no args -- source-tran-expander" x)) + (let ((h (macroexpand (cadr x))) + (n (macroexpand (caddr x))) + tmp) + (cond ((setq tmp (si:index+2-examine h n)) + (if (eq (car x) 'SI:XREF) + `(CXR ,tmp ,h) + `(RPLACX ,tmp ,h ,(cadddr x)))) + ((let* ((htmp (si:gen-local-var () "EX")) + (ntmp (si:gen-local-var () "I")) + (indx `(+ #.si:extend-q-overhead ,ntmp)) + (body (if (eq (car x) 'SI:XREF) + `(CXR ,indx ,htmp) + `(RPLACX ,indx ,htmp ,(cadddr x))))) + `((LAMBDA (,htmp ,ntmp) + (DECLARE (FIXNUM ,ntmp)) + ,body) + ,h ,n)))))) + ((SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND) + ;; This function MUST be open-compilable so that the + ;; output of DEFVST doesn't require the whole world! + (let ((size (cadr x)) + (clss (caddr x)) + (v (si:gen-local-var () "EX"))) + `(LET ((,v (MAKHUNK (+ ,size #.si:extend-q-overhead)))) + (SETF #%(SI:EXTEND-CLASS-OF ,v) ,clss) + (SETF #%(SI:EXTEND-MARKER-OF ,v) '**SELF-EVAL**) + ,v))) + ((EXTEND-LENGTH SI:EXTEND-LENGTH) + `(- (HUNKSIZE ,(cadr x)) #.si:extend-q-overhead)) + (SI:EXTEND `(HUNK '**SELF-EVAL** ,@(cddr x) ,(cadr x))) + (T (+internal-lossage 'SI:XSTUFF-expander 'SI:XSTUFF-expander x))) + 'T)) + + +(let (z) + (mapc #'(lambda (x) + (or (memq #'SI:XSTUFF-expander (setq z (get x 'SOURCE-TRANS))) + (putprop x (cons #'SI:XSTUFF-expander z) 'SOURCE-TRANS))) + '(SI:XREF SI:XSET SI:EXTEND-LENGTH EXTEND-LENGTH + SI:MAKE-EXTEND SI:MAKE-RANDOM-EXTEND SI:EXTEND))) + + + + +;;Watch out for bootstrapping problems if SI:CLASS-INSTANCE-SIZE should +;; ever change, or if ever EXTSTR-USERATOMS-HOOK is to be applicable +;; to objects other than hunks + +(defun EXTSTR-USERATOMS-HOOK (obj) + (declare (special SI:SKELETAL-CLASSES)) + (cond ((not (hunkp obj)) () ) ;all EXTENDs are hunks!! + ((and (eq (si:extend-marker-of obj) SI:CLASS-MARKER) + (= (hunksize obj) + #.(+ si:class-instance-size si:extend-q-overhead)) + (if (fboundp 'CLASSP) + (and (classp obj) + (memq (si:class-name obj) '#.si:extstr-setup-classes)) + #.`(OR ,.(mapcar #'(lambda (x) `(EQ OBJ ,x)) + si:extstr-setup-classes)))) + ;;Special case for referencing class objects + `((GET ',(si:class-name obj) 'CLASS))) + ((and SI:SKELETAL-CLASSES (assq obj SI:SKELETAL-CLASSES)) + ;; Do we ever really want to get ourselves in this predicament? + (let ((frob (assq obj SI:SKELETAL-CLASSES))) + `((OR (GET ',(si:class-name obj) 'CLASS) + (AND (GET 'EXTSTR 'VERSION) + (SI:DEFCLASS*-2 ',(si:class-name obj) + ',(si:class-typep obj) + ',(si:class-var obj) + ',(cadr frob))))))) + ((and (fboundp 'EXTENDP) (extendp obj)) (send obj 'USERATOMS-HOOK)))) + +(and (boundp 'USERATOMS-HOOKS) + (or (memq 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS) + (push 'EXTSTR-USERATOMS-HOOK USERATOMS-HOOKS))) + diff --git a/src/lspsrc/extmdf.29 b/src/lspsrc/extmdf.29 new file mode 100755 index 00000000..4f7a6449 --- /dev/null +++ b/src/lspsrc/extmdf.29 @@ -0,0 +1,49 @@ +; -*-MIDAS-*- +TITLE EXTMDF -- Midas definitions for CLASS fields + +DEFINE CDEF index,prefix,parity,long,short + prefix!short==index + DEFINE %!long ac1,obj + h!parity!rz ac1,prefix!short obj + TERMIN + DEFINE $!long ac1,obj + hr!parith!m ac1,prefix!short obj + TERMIN +TERMIN + +IRPW SYMS,,[ +CLASS,CLS ;; CLASS of this CLASS +MARKER,MRK ;; Marker to distinguish classes from hunks +SENDI,SND ;; LSUBR-like function to jump to for SENDs to instances +SENDSYM,SNS ;; Original symbol or LAMBDA the LSUBR came from +CALLI,CLI ;; Similar to SENDI but for function calling +CALLSYM,CLS ;; ditto +MAPMTH,MMT ;; MAP-OVER-METHODS SUBR +MAPMSYM,MMS ;; MAP-OVER-METHODS SUBR's Symbol +MAPCLS,MCL ;; MAP-OVER-CLASS SUBR +MAPCSYM,MCL ;; MAP-OVER-CLASS SUBR's Symbol +ADMTH,ADM ;; Add method routine. FUNCALLed +TYPEP,TYP ;; What to return to TYPEP (except in BD MacLisp) +SUPER,SUP ;; List of superiors, in order of search +NAME,NAM ;; Name of this class, short form of the var +METHD,MTH ;; Table (or list) of Methods. Interpreted by SENDI slot. +ATTRI,ATR ;; PLIST of random information +] +IFE .irpcnt&1, CDEF \<.irpcnt/2>,CR$,R,SYMS ;Don't delete this comment +.ELSE CDEF \<.irpcnt/2>,CL$,L,SYMS ;Or this one either! +TERMIN + +IRPW SYMS,,[ +MNEXT,NXT ;; Next method in bucket chain +MNAME,NAM ;; Method symbol, name of method +MSUBR,SRB ;; LSUBR property for method, or trampoline to interpreted +MFSYM,FSY ;; Name of method function, for reference or trampoline +] +IFE .irpcnt&1, CDEF \<.irpcnt/2>,MR$,R,SYMS ;This comment required +.ELSE CDEF \<.irpcnt/2>,ML$,L,SYMS ;Do to MIDAS parsing stuff +TERMIN + +;Local Modes: ::: +;Comment Column:17 ::: +;Comment Start:;; ::: +;End: ::: diff --git a/src/lspsrc/gcdemn.14 b/src/lspsrc/gcdemn.14 new file mode 100755 index 00000000..7cd6f32a --- /dev/null +++ b/src/lspsrc/gcdemn.14 @@ -0,0 +1,307 @@ +;;; GCDEMN -*-LISP-*- +;;; ************************************************************** +;;; ***** MACLISP ******* Standard GC-DAEMON function ************ +;;; ************************************************************** +;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* +;;; ************************************************************** + +;; Note that "HERALD" call is below, to insure that the addition +;; to GC-DAEMON has occured before the VERSION property is put +;; (HERALD GCDEMN /14) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; This is a dynamic garbage collector daemon which tries to predict +;;; consing in the various spaces based on past performance and thus to +;;; set space sizes such that garbage collection is minimized. +;;; +;;; The algorithm is from Henry Baker and the program is his with minor +;;; modifications. JONL maintained Baker's code between 1978 and 1980, +;;; and PSZ made significant modifications on July 12, 1980. GSB added +;;; some type-declarations, and added a separater gc-statistics print +;;; switch on Feb 6, 1981; GSB and JONL added some efficiency hacks +;;; to do less consing on Feb 6-7, 1981, and to use HERALD +;;; GSB hacked the gc-statistics print switch to be more usable Feb. 19, +;;; 1981; the variable GC-DAEMON-PRINT should have as its value a variable +;;; which will be SYMEVALed to see if the gc-daemon should print statistics. +;;; By default its value is ^D, causing the gc-daemon to print statistics +;;; when the Lisp gc does. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; For historical purposes, the original CGOL code is reproduced +;;; here as commentary. All running code is now in LISP +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; (cgol) +;; +;; declare(muzzled(t)) % Shut up about closed compilation. % +;; +;; % GC-daemon for optimal allocation. % +;; % Described in AI Working Paper #142. % +;; % set "alloc-mark-ratio" to a flonum between 0.2 and 5.0. % +;; +;; sstatus(who1,42.,"%",118.,0.) % Set up "who" line on tv's. % +;; sstatus(gcwho,3.) +;; who3 := "GCDEMN" +;; +;; % Initialize property lists of space names. % +;; let gc_daemon= +;; '\spacelist; +;; (let alloct=nil.alloc(t); +;; for element in spacelist +;; do (let space = car(element), +;; freebefore = cadr(element), +;; freeafter = caddr(element), +;; sizebefore = cadddr(element), +;; sizeafter = car(cddddr(element)); +;; % Initialize state of each space for gc-daemon. % +;; accessible ofq space := sizeafter-freeafter; +;; % Make sure that we don't get a gc-overflow interrupt. % +;; alloc([space,[max(512.,car(space of alloct) or sizeafter), +;; 262143., +;; if sizeafter>0 then 32. else 0.]])))' +;; in gc() +;; +;; alloc_mark_ratio := 1.0  +;; +;; special alloc_mark_ratio +;; +;; define "GC-DAEMON" (spacelist); +;; let total_accessible = 0.0, +;; total_consed = 0.0; +;; % Go through spaces and accumulate consed and accessible +;; information. % +;; for element in spacelist % Argument is "alist" of spaces. % +;; do (let space = car(element), % Give names to parameters. % +;; freebefore = cadr(element), +;; freeafter = caddr(element), +;; sizebefore = cadddr(element), +;; sizeafter = car(cddddr(element)); +;; % Compute consed since last gc and accessible now for this space. % +;; consed ofq space := sizebefore-freebefore-accessible ofq space; +;; total_consed := total_consed + consed ofq space; +;; accessible ofq space := sizeafter-freeafter; +;; total_accessible := total_accessible + accessible ofq space); +;; % Store total consed, total accessible and compute total free. % +;; consed ofq 'total_storage' := total_consed; +;; accessible ofq 'total_storage' := total_accessible; +;; let total_free = alloc_mark_ratio * total_accessible; +;; free ofq 'total_storage' := total_free; +;; % Go through spaces and re-allocate where necessary. % +;; for element in spacelist +;; do (let space = car element; +;; alloc_rate ofq space := consed ofq space / total_consed; +;; free ofq space := fix(total_free * alloc_rate ofq space); +;; let spcsize = accessible ofq space + free ofq space + 511.; +;; if spcsize>511. then alloc([space,[spcsize,262143.,32.]])) +;; +;; gc_daemon := 'gc_daemon' +;; +;; =exit + + +(declare (setq USE-STRT7 T) + (special GCDEMN-SETUP-1/|) ) + +(defvar ALLOC-MARK-RATIO 1.0) +(defvar FILL-STORAGE-FRACTION 0.5) +; We SYMEVAL this to see if we want to print statistics. +(defvar GC-DAEMON-PRINT '^D) + +(eval-when (eval compile) + (defmacro fix-to-float (x) + `(float (fixnum-identity ,x))) + (defmacro float-to-fix (x) + `(ifix (flonum-identity ,x))) + (defmacro defmaxmin (max-name min-name type + &aux (v1 (gensym)) (v2 (gensym))) + + `(progn 'compile + (defmacro ,max-name (arg1 arg2) + (list '(lambda (,v1 ,v2) + (declare (,type ,v1 ,v2)) + (cond ((> ,v1 ,v2) ,v1) (t ,v2))) + arg1 arg2)) + (defmacro ,min-name (arg1 arg2) + (list '(lambda (,v1 ,v2) + (declare (,type ,v1 ,v2)) + (cond ((< ,v1 ,v2) ,v1) (t ,v2))) + arg1 arg2)))) + (defmaxmin max$ min$ flonum) + (defmaxmin max% min% fixnum) + ) + + +(defun GC-DAEMON-PRINT (space cons-rate oldgcsize marked gcsize spcsize) + ;; We print for each non-empty space the following information: + ;; CONS-RATE The % of conses since the last GC which were for + ;; this space. + ;; OLDGCSIZE Size of the space in words before GC. + ;; MARKED Number of words marked as "in use" by GC. + ;; GCSIZE Size in words recommended by daemon. + ;; SPCSIZE (if present) Actual size of space if different from size. + ((lambda (base *nopoint f) + (setq cons-rate (fix (*$ cons-rate 100.0))) + (and (< (linel f) + (+ (flatc space) (flatc cons-rate) (flatc oldgcsize) + (flatc marked) (flatc gcsize) (flatc spcsize) 10. + (charpos f))) + (princ '| +; | msgfiles)) + (princ space msgfiles) + (princ '| | msgfiles) + (princ cons-rate msgfiles) + (princ '|%[| msgfiles) + (princ oldgcsize msgfiles) + (princ '|->| msgfiles) + (princ marked msgfiles) + (princ '|//| msgfiles) + (princ gcsize msgfiles) + (cond ((not (= spcsize gcsize)) + (princ '|//| msgfiles) (princ spcsize msgfiles))) + (princ '|] | msgfiles)) + 10. t (cond ((or (memq tyo msgfiles) (and (not ^w) (memq t msgfiles))) + tyo) + ((car (delq t (append msgfiles nil)))) + (t tyo)))) + + + +(DEFUN BAKER-GC-DAEMON (SPACELIST) + ((LAMBDA (RUNTIME TOTAL-ACCESSIBLE TOTAL-CONSED MEMFREE) + (declare (fixnum runtime) (flonum total-accessible total-consed)) + (MAPC + (FUNCTION + (LAMBDA (ELEMENT) + ((LAMBDA (SPACE FREEBEFORE FREEAFTER SIZEBEFORE SIZEAFTER) + ; No point in declarations, they only pessimize the compiler, + ; in this case. + (PUTPROP SPACE (- SIZEBEFORE FREEBEFORE (GET SPACE 'ACCESSIBLE)) + 'CONSED) + (SETQ TOTAL-CONSED (+$ TOTAL-CONSED (fix-to-float (GET SPACE 'CONSED)))) + (PUTPROP SPACE (- SIZEAFTER FREEAFTER) 'ACCESSIBLE) + (SETQ TOTAL-ACCESSIBLE (+$ TOTAL-ACCESSIBLE + (fix-to-float (GET SPACE 'ACCESSIBLE))))) + (CAR ELEMENT) (CADR ELEMENT) (CADDR ELEMENT) + (CADDDR ELEMENT) (CAR (CDDDDR ELEMENT))))) + SPACELIST) + (PUTPROP 'TOTAL-STORAGE TOTAL-CONSED 'CONSED) + (PUTPROP 'TOTAL-STORAGE TOTAL-ACCESSIBLE 'ACCESSIBLE) + ((LAMBDA (TOTAL-FREE alloct ALLOC-LIST + ALLOC-LIST-1 SPACE-HACK SPACE-HACK-1) + (declare (flonum total-free)) + (PUTPROP 'TOTAL-STORAGE TOTAL-FREE 'FREE) + (and (symeval gc-daemon-print) + ((lambda (base *nopoint) + ; Kludge: if the GC printed, we do NOT want an extra newline; but + ; if it do not, we need to print one ourselves. + (or ^d (terpri msgfiles)) + (princ '|;GC-DAEMON: cons-rate%[oldgcsize->marked//gcsize//spcsize] +; Consed=| + msgfiles) + (princ (fix total-consed) msgfiles) + (princ '|, Marked=| msgfiles) + (princ (fix total-accessible) msgfiles) + (princ '|, Allocated//Marked=| msgfiles) + (princ alloc-mark-ratio msgfiles) + (princ '|, Memfree= | msgfiles) + (princ memfree msgfiles) + (princ '| +; | msgfiles)) + 10. t)) + (MAPC + (FUNCTION + (LAMBDA (ELEMENT) + ((LAMBDA (SPACE) + ((lambda (alloc-rate) + (declare (flonum alloc-rate)) + (putprop space alloc-rate 'alloc-rate) + (putprop space (fix (*$ total-free alloc-rate)) 'free)) + (//$ (fix-to-float (get space 'consed)) total-consed)) + ((LAMBDA (SPCSIZE) + (declare (fixnum spcsize)) + (and (symeval gc-daemon-print) + (get alloct space) + (gc-daemon-print + space + (get space 'alloc-rate) + (car (get alloct space)) + (get space 'accessible) + (* 512. (// spcsize 512.)) + (status spcsize space))) + (COND ((GREATERP SPCSIZE 511.) + (OR ALLOC-LIST + (SETQ ALLOC-LIST + (LIST NIL (SETQ ALLOC-LIST-1 + (LIST NIL 262143. NIL))) + SPACE-HACK + (LIST 'SPCSIZE + (CONS 'QUOTE (SETQ SPACE-HACK-1 + (LIST NIL)))))) + (rplaca space-hack-1 space) + (RPLACA + (CDDR (RPLACA ALLOC-LIST-1 + (max% SPCSIZE + (apply 'status space-hack)))) + (cond ((eq space 'list) 200.) (t 32.))) + (ALLOC (RPLACA ALLOC-LIST SPACE))))) + (+ (GET SPACE 'ACCESSIBLE) (GET SPACE 'FREE) 511.))) + (CAR ELEMENT)))) + SPACELIST) + (and (symeval gc-daemon-print) (terpri msgfiles))) + (min$ (*$ ALLOC-MARK-RATIO TOTAL-ACCESSIBLE) + (*$ (fix-to-float memfree) fill-storage-fraction)) + (cons nil (alloc t)) NIL NIL NIL NIL) + ; Finally, add our runtime into the total gc-time. + (setq runtime (- (status gctime) runtime)) + (sstatus gctime (+ (runtime) runtime)) + ) + (runtime) 0.0 0.0 (status memfree))) + + + + +;; This function takes relatively little space, in comparison to all that +;; needed for the names of the variables used. If run as expr code, +;; these symbols would never go away. + +(defun GCDEMN-SETUP-1/| (x) + (let (((space freebefore freeafter sizebefore sizeafter) x)) + ;;The variable GCDEMN-SETUP-1/| has been set to `(() ,.(alloc t)) + (putprop space (- sizeafter freeafter) 'ACCESSIBLE) + (let ((spacesize (or (car (get GCDEMN-SETUP-1/| space)) + sizeafter)) + (spacemin (cond ((not (> sizeafter 0)) () ) + ((eq space 'LIST) 200.) + (32.)))) + (if (< spacesize 512.) (setq spacesize 512.)) + (alloc `(,space (,spacesize 262143. ,spacemin)))))) + +(cond + ;;If this file is loaded more than once, then don't 'push' onto + ;; the GC-DAEMON variable again. + ((or (get 'GCDEMN 'VERSION) (eq gc-daemon 'baker-gc-daemon))) + (T (cond ((status SSTATUS GCWHO) + (sstatus WHO1 42. '% 118. 0.) + (sstatus GCWHO 3.) + (sstatus WHO3 'GCDEMN) )) + ;;; Initially set things up + (let ((GCDEMN-SETUP-1/| `(() ,.(alloc t))) + (GC-DAEMON #'(lambda (z) (mapc #'GCDEMN-SETUP-1/| z))) ) + (gc)) + (setq GC-DAEMON + (cond ((null GC-DAEMON) 'BAKER-GC-DAEMON) + ((let ((x (gensym))) + `(LAMBDA (,x) + (,.(cond ((or (symbolp gc-daemon) + (and (not (atom gc-daemon)) + (eq (car gc-daemon) 'LAMBDA))) + `(,gc-daemon)) + (`(FUNCALL ',gc-daemon))) + ,x) + (BAKER-GC-DAEMON ,x)))))) )) + +(herald GCDEMN /14) \ No newline at end of file diff --git a/src/lspsrc/gfile.422 b/src/lspsrc/gfile.422 new file mode 100755 index 00000000..9c11cfe5 --- /dev/null +++ b/src/lspsrc/gfile.422 @@ -0,0 +1,335 @@ + + +;;; -*-LISP-*- +;;; *********************************************************************** +;;; ***** Maclisp ****** S-expression formatter for files (grind) ********* +;;; *********************************************************************** +;;; ** (c) Copyright 1980 Massachusetts Institute of Technology *********** +;;; ****** this is a read-only file! (all writes reserved) **************** +;;; *********************************************************************** +;;; This version of Grind works in both ITS Maclisp and Multics Maclisp +;;; GFILE - fns for pretty-printing and grinding files. + +(eval-when (eval compile) + (or (status nofeature MACLISP) + (status macro /#) + (load '((LISP) SHARPM))) +) + +(herald GRIND /422) + +(declare (array* (notype (gtab/| 128.))) + (special merge readtable grindreadtable remsemi ~r + grindpredict grindproperties grindef predict + grindfn grindmacro programspace topwidth + grindlinct global-lincnt /; /;/; user-paging form + prog? n m l h arg chrct linel pagewidth gap comspace + grindfill nomerge comnt /;/;? ^d macro unbnd-vrbl + cnvrgrindflag outfiles infile stringp) + (*expr form topwidth programspace pagewidth comspace + nomerge remsemi stringp) + (*fexpr trace slashify unslashify grindfn grindmacro + unreadmacro readmacro grindef) + (*lexpr merge predict user-paging grindfill testl) + (mapex t) + (genprefix gr+) + (fixnum nn + mm + (grchrct) + (newlinel-set fixnum) + (prog-predict notype fixnum fixnum) + (block-predict notype fixnum fixnum) + (setq-predict notype fixnum fixnum) + (panmax notype fixnum fixnum) + (maxpan notype fixnum fixnum) + (gflatsize))) + + + + +(prog () ;some initializations + (and (not (boundp 'grind-use-original-readtable)) + (setq grind-use-original-readtable t)) + (and (or (not (boundp 'grindreadtable)) ;readtable (default). + (null grindreadtable)) + ((lambda (readtable) (setsyntax 12. 'single ()) ;^l made noticeable. + (setsyntax '/; + 'splicing + 'semi-comment)) + (setq grindreadtable + (*array () + 'readtable + grind-use-original-readtable)))) + (setq macro '/; + /; (copysymbol '/; ()) + /;/; (copysymbol '/;/; ())) + (setq grindlinct 8. global-lincnt 59. comnt () /;/;? ()) + (setq stringp (status feature string)) +) + + +;;; Grinds and files file. +(defun grind fexpr (file) + ((lambda (x) + (cond ((and stringp (stringp (car file)))) ;already filed. + (t (cond ((not (status feature its)) + (cond ((status feature DEC20) + (setq x (append (namelist x) () )) + (rplacd (cddr x) () )) + ((probef x) (deletef x))))) + (apply 'ufile x))) + file) + (apply 'grind0 file))) + + (defun grind0 fexpr (file) ;grinds file and returns file + (or (status feature grindef) + (funcall autoload (cons 'grindef (get 'grindef 'autoload)))) + (prog (remsemi linel *nopoint readtable base l ^q ^r ^w ^d + outfiles eof n /;/;? comnt terpri) + (setq base 10. linel programspace + readtable grindreadtable remsemi t) + (cond + ((and stringp (stringp (car file))) + (inpush (openi (car file))) + (setq + outfiles + (list + (openo + (mergef + (cond ((null (cdr file)) + (princ '|/îFiling as !GRIND OUTPUT |) + '(* /!GRIND OUTPUT)) + ((cadr file))) + (cons (car (namelist ())) '*) ))))) + ('t (apply (cond ((status feature sail) 'eread) ('uread)) + (cond ((and (null (cdr file)) (symbolp (car file))) + (car file)) + ((and (status feature sail) + (cadr file) + (eq (cadr file) 'dsk)) + (cons (car file) (cons '| | (cdr file)))) + ('t file))) + (uwrite))) + (setq eof (list ()) n topwidth) + (setq ^q t ^r t ^w t grindlinct global-lincnt) + read (and (= (tyipeek 47791616. -1) + 59.) ;catch top-level splicing macro + (readch) + (cond ((eq (car (setq l (car (semi-comment)))) /;) + (rem/;) + (go read)) + (t (go read1)))) + (and (null ^q) (setq l eof) (go read1)) ;catch eof in tyipeek + (and (eq (car (setq l (read eof))) /;) ;store /; strings of /; comments. + (rem/;) + (go read)) + read1(prinallcmnt) ;print stored /; comments + (or (eq eof l) (go process)) + exit (terpri) + (setq ~r ()) + (and stringp + (stringp (car file)) + (close (car outfiles))) ;won't get ufile'd + (return file) + process + (cond ((eq l (ascii 12.)) ;formfeed read in ppage mode + (or user-paging (go read)) ;ignore ^l except in user-paging mode. + (and (< (tyipeek 50167296. -1) 0) + (go exit)) ;any non-trivial characters before eof? + (terpri) + (grindpage) + (setq /;/;? t) + (go read)) + ((eq (car l) /;/;) ;toplevel ;;... comment + (newlinel-set topwidth) + (or /;/;? (= linel (grchrct)) (turpri) (turpri)) ;produces blank line preceding new + (rem/;/;) ;block of /;/; comments. (turpri is + (newlinel-set programspace) ;already in rem/;/;). a total of 3 + (go read))) ;turpri's are necessary if initially + (fillarray 'gtab/| '(())) ;chrct is not linel, ie we have just + (cond (user-paging (turpri) (turpri)) ;finished a line and have not yet cr. + ((< (turpri) + (catch (\ (panmax l (grchrct) 0.) 60.))) ;clear hash array + (grindpage)) + ((turpri))) + (cond ((eq (car l) 'lap) (lap-grind)) + ((sprint1 l linel 0.) (prin1 l))) + (tyo 32.) ;prevents toplevel atoms from being + (go read))) ;accidentally merged by being separated only by + ;cr. + + +(defun newlinel-set (x) + (setq chrct (+ chrct (- x linel)) + linel x)) + +(putprop /; '(lambda (l n m) 0.) 'grindpredict) + +(putprop /;/; '(lambda (l n m) 1.) 'grindpredict) + +;;semi-colon comments + +(defun rem/; () + (prog (c retval) + a (cond ((atom l) (return retval)) + ((eq (car l) /;) + (setq c (cdr l)) + (setq retval 'car) + (setq l ())) + ((and (null (atom (car l))) (eq (caar l) /;)) + (setq c (cdar l)) + (setq retval 'caar) + (setq l (cdr l))) + (t (cond ((and (eq retval 'caar) ;look ahead to separate comments. + (cdr l) + (null (atom (cdr l))) + (null (atom (cadr l))) + (eq (caadr l) /;)) + (prinallcmnt) + (indent-to n))) + (return retval))) + b (cond ((null comnt) (setq comnt c)) + ((< comspace (length comnt)) (turpri) (go b)) + ((nconc comnt (cons '/ c)))) + (go a))) + + +(defun rem/;/; () + (prog (c retval) + a (cond ((atom l) + (and (eq retval 'caar) (indent-to n)) + (return retval)) + ((eq (car l) /;/;) + (setq c (cdr l)) + (setq retval 'car) + (setq l ())) + ((and (null (atom (car l))) (eq (caar l) /;/;)) + (setq c (cdar l)) + (setq retval 'caar) + (setq l (cdr l))) + (t (and (eq retval 'caar) (indent-to n)) ;restore indentation for upcoming code + (return retval))) + (prinallcmnt) + (and (null /;/;?) (turpri)) + (prog (comnt pagewidth comspace macro) + (setq comnt c) + (and (or (memq (car c) '(/; *)) + (null merge)) ;nomerge. update pagewidth, comspace + (setq /;/;? '/;/;/;) ;appropriate for a total line of + (setq pagewidth topwidth ;topwidth + comspace (+ n (- topwidth linel))) + (go prinall)) + (setq pagewidth linel) + (cond ((eq /;/;? /;/;) ;preceding comnt. merge. + (setq comnt (cons '/ comnt)) + (setq macro (ascii 0.)) + (setq comspace (grchrct)) + (prin50com)) + ((setq /;/;? /;/;))) + (setq comspace n) + prinall + (setq macro /;/;) + (prinallcmnt)) + (tj6 c) + (go a))) + +(defun tj6 (x) ;tj6 commands: ;;*--- or ;;*(...) (...) + (and + (eq (car x) '*) + (setq x (cdr x)) + (turpri) + (cond + ((errset + (cond ((atom (car (setq x + (readlist (cons '/( + (nconc x + '(/)))))))) + (eval x)) + ((mapc 'eval x))))) + ((error '/;/;*/ error x 11.))))) + + +(defun prin50com () ;prints one line of ; comment + (prog (next) + (newlinel-set pagewidth) ;update linel, chrct for space of pagewidth. + (prog (comnt) (indent-to comspace)) + (princ macro) + pl + (cond ((null comnt) (return ())) + ((eq (car comnt) '/ ) + (setq comnt (cdr comnt)) + (setq next + (do ((x comnt (cdr x)) (num 2. (1+ num))) ;number of characters till next space. + ((or (null x) (eq (car x) '/ )) + num))) + (cond ((and (or (eq macro /;) (eq /;/;? /;/;)) + grindfill + (= next 2.) + (go pl))) + ((and (not (eq macro (ascii 0.))) + (> next comspace))) + ((< (grchrct) next) (return ()))) + (tyo 32.) + (go pl)) + ((> (grchrct) 0.) + (princ (car comnt)) + (and (or (eq macro /;) (eq /;/;? /;/;)) + grindfill + (eq (car comnt) '/.) + (eq (cadr comnt) '/ ) + (tyo 32.))) + (t (return ()))) + (setq comnt (cdr comnt)) + (go pl)) + (newlinel-set programspace)) ;may restore chrct to be negative. + +(defun prinallcmnt () (cond (comnt (prin50com) (prinallcmnt)))) ;prints \ of ; comment + +(defun semi-comment () ;converts ; and ;; comments to exploded + (prog (com last char) ;lists + (setq com (cons /; ()) last com) + (setq char (readch)) ;decide type of semi comment + (cond ((eq char '/ +) (return (list com))) + ((eq char '/;) (rplaca last /;/;)) + ((rplacd last (cons char ())) + (setq last (cdr last)))) + a (setq char (readch)) + (cond ((eq char '/ +) (return (list com))) + ((rplacd last (cons char ())) + (setq last (cdr last)) + (go a))))) + + +(defun grindcolmac () (list ': (read))) + +(defun grindcommac () (list '/, (read))) + +(defun grindatmac () (cons '@ (read))) + +(defun grindexmac () + (prog (c f) + (setq c (grindnxtchr)) + ta (cond ((setq f (assq c '((" /!") (@ /!@) ($ /!$)))) + (tyi) + (return (cons (cadr f) (read)))) + ((setq f (assq c + '((? /!?) (/' /!/') (> /!>) (/, /!/,) + (< /!<) (/; /!/;)))) + (tyi) + (setq f (cadr f))) + (t (setq c (error 'bad/ /!/ macro + c + 'wrng-type-arg)) + (go ta))) + (return (cond ((grindseparator (grindnxtchr)) + (list f ())) + ((atom (setq c (read))) (list f c)) + (t (cons f c)))))) + +(defun grindnxtchr () (ascii (tyipeek))) + +(defun grindseparator (char) (memq char '(| | | | |)|))) ;space, tab, rparens + +(sstatus feature grind) diff --git a/src/lspsrc/gfn.462 b/src/lspsrc/gfn.462 new file mode 100755 index 00000000..7d11d714 --- /dev/null +++ b/src/lspsrc/gfn.462 @@ -0,0 +1,1520 @@ +;;; GFN -*-LISP-*- +;;; ************************************************************** +;;; ***** Maclisp ****** S-expression formatter (grindef) ******** +;;; ************************************************************** +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology ** +;;; ****** this is a read-only file! (all writes reserved) ******* +;;; ************************************************************** +;;; +;;; 04/06/81 kmp - renamed PREDICT to GPREDICT to avoid name conflicts with +;;; other systems. for compatibility, i do a +;;; (DEFPROP PREDICT GPREDICT EXPR) iff PREDICT is not +;;; fboundp at load time. this defprop should go away sometime +;;; after people have made the changeover. +;;; 01/29/81 jonl - flushed (STATUS FEATURE MACAID) and NIL --> () +;;; added special declaration for GRIND-MACROEXPANDED +;;; 04/15/80 kmp - made GRLINEL use the value of GRLINEL variable if it is +;;; bound rather than guessing about a LINEL by looking at +;;; outfiles. It is defaultly UNBOUND. +;;; 04/13/80 rwk - made SETF grind like SETQ. Added OWN-SYMBOL's for system +;;; funs. Converted THROW's to *THROWs, CATCH's to *CATCHs. +;;; Tag in both cases of () +;;; 04/02/80 rees - introduced GATOMP in an attempt to make handling of +;;; hunks more consistent. Complete crockery. +;;; Also added variable GRIND*RSET so I can debug the +;;; damn thing. +;;; 02/28/80 kmp - removed buggy COND for re-examination, too. sigh. +;;; 02/27/80 kmp - removed LET and CASEQ buggy grindfn properties until +;;; they can be looked into in more detail. They don't +;;; currently do the right thing as GLS points out. +;;; 02/24/80 kmp - added grind properties for DO and CASEQ. Fixed DEF-FORM +;;; to handle DEFMACRO and DEFUN& optimally. +;;; 02/18/80 kmp - nreversed this history to put new entries at the top +;;; fixed. Made EVAL-WHEN grind right. +;;; 02/14/80 kmp - flushed some old, unreachable code from several points, +;;; clearly marked. Made LET/LAMBDA grind right. +;;; 02/11/80 kmp - hunk pretty-printing supported. depends on the variable +;;; hunkp being non-nil and the variable hunksprin1 being +;;; set to a pretty-printer. default printers provided. +;;; if either variable is NIL, hunks are sprinter'd like lists. +;;; fixed a probably non-existent bug in the sprintering of +;;; non-atomic atoms in the cdr of a cons. +;;; 02/04/80 jonl - lambda-bind *RSET for "interior" calls, to achieve speed. +;;; Installed use of HERALD and DEFSIMPLEMAC (in MULTICS +;;; case) "require"ing loading MACAID +;;; 11/28/79 alan - fixed GFLATSIZE1 (see kmp 6/18/79) to only look at +;;; property lists of symbols (e.g. not lists!) +;;; 11/15/79 kmp - fixed SPRIN1 to take a file object as second arg, augmenting +;;; addition to former ability to take a list of files... +;;; 11/8/79 rees - minor bug fixes, e. g. ",." flatsizing, 2nd SPRIN1 +;;; arg, VERSION property and (LISP) device modernization +;;; 09/27/79 rees - Changed name of "FORM" to "GRINDFORM" +;;; Added function SPRIN1 for prettyprinting PRIN1 +;;; 09/25/79 jonl - Changed name of "FILL" to "GRINDFILL" +;;; Installed some usage of # +;;; 06/19/79 kmp - Fixed bug that non-null end of list in 'block'-type +;;; special forms were blindly CAR'ing and CDR'ing +;;; the atom. +;;; 06/18/79 kmp - Added in GFLATSIZE1 and ability to check for a +;;; GRINDFLATSIZE property on CAR's of forms. +;;; 05/24/79 jonl - Add some special grindmacro functions for backquote +;;; and defmacro stuff. +;;; 05/03/79 kmp - lambda-bind ERRSET when loading init file so people +;;; with ERRSET handlers don't get breakpoints at what +;;; is really a non-error. (version 421) +;;; 03/30/79 jonl - flush CNVR stuff, put in a modern loading-message-print, +;;; and a modern-style init file finder. +;;; 01/09/79 jonl - flush "niop/|", since only newio is available. Fix up +;;; autoload property for GRILAP +;;; 11/01/78 jonl - print loading message on MSGFILES instead of OUTFILES +;;; don't GRINDEF is atomic arg is not a SYMBOL +;;; 09/15/78 {hic?} - let "*" be returned instead of (ascii 0) +;;; 07/12/78 jonl - Fix up usages of LINEL by creating function GRLINEL, +;;; and install macros for POPL and REMSEMI-TAC +;;; 05/25/78 jonl - Had GRINDEF and SPRINTER lambda-bind variable LINEL, and +;;; removed all references to CONNIVER and PLANNER stuff. +;;; Flush "SGPLOSES" and NOARGS calls; flush GBREAK. +;;; Change "NIL" into "()". +;;; 09/13/76 jonl - changed loading message for qio, removed "M" from +;;; toplevel setqs +;;; 11/01/75 jonl - Fixed up the autoload properrty makers for slashify etc. +;;; 10/10/75 jonl - Added mem-form property for fillarray +;;; 09/18/75 jonl - Fixed up a few newio goodies, and removed more grind +;;; stuff to gfile +;;; 08/07/75 jonl - Flushed newio macroified stuff, and made dynamic +;;; 06/14/75 jonl - Flushed remgrind. repaired ghash to work on dec-10 +;;; 05/7/75 ? - Vertical-bars and exclamations slashed +;;; 09/21/74 maxpan made into 3 arg fn. third arg = m. /Eliminate +;;; excessive specbinding. grindpredict obtained via apply. + +(herald GRINDEF /462) + + + +(declare (own-symbol READMACROINVERSE SPRINTER SPRIN1 GRINDEF + |MACROEXPANDED-grindmacro/|| |+INTERNAL-`-grindmacros/||)) + +(declare (array* (notype (gtab/| 128.))) + (special /; /;/; /;/;? arg chrct comnt comspace gap global-lincnt + grind-standard-quote grindef grindfill grindfn grindform + grindlinct grindmacro grindmerge grindnomerge grindpredict + grindproperties grindreadtable h l linel m macro n outfiles + pagewidth gpredict prog? programspace readtable remsemi + sprin1 + topwidth unbnd-vrbl user-paging hunksprin1 grind*rset + grlinel grind-macroexpanded) + (*expr grindform topwidth programspace pagewidth comspace + grindnomerge remsemi) + (*fexpr trace slashify unslashify grindfn grindmacro + unreadmacro readmacro grindef) + (*lexpr grindmerge gpredict user-paging grindfill testl) + (*expr prin50com rem/;/; rem/;) ;; Imported from GFILE + (mapex 't) + (genprefix /|gr) + (fixnum nn mm + (prog-predict notype fixnum fixnum) + (block-predict notype fixnum fixnum) + (setq-predict notype fixnum fixnum) + (panmax notype fixnum fixnum) + (maxpan notype fixnum fixnum) + (gflatsize) (grchrct) (grlinel))) + +(cond ((not (boundp 'hunksprin1)) + (setq hunksprin1 'standard-hunksprin1))) +(cond ((not (boundp 'grind*rset)) + (setq grind*rset ()))) + +;;;REMSEMI - test and call + +(declare (setq defmacro-for-compiling () defmacro-displace-call () )) + + (defmacro remsemi-tac () '(and remsemi (remsemi))) + (defmacro popl () '(progn (pop l) (remsemi-tac) l)) + ;;; replaced by compiler by tab (8 its, 10. multics) + (defmacro stat-tab () `(quote ,(status tabsize))) + #+multics + (defsimplemac ghash (x) + `(cond ((atom ,x) (abs (sxhash ,x))) + ((maknum ,x)))) + #-multics + (defmacro ghash (x) `(maknum ,x)) + + +(prog (*RSET) + (*rset grind*rset) + ;;;some initializations + (and (not (boundp 'grind-use-original-readtable)) + (setq grind-use-original-readtable 't)) + ;;; standard readmacroinverter for quote. "quote" + ;;; If you have your own macro for quote take effect, set + ;;; grind-standard-quote to (). + (and (not (boundp 'grind-standard-quote)) + (setq grind-standard-quote 't)) + (setq remsemi () + grindlinct 8. + grindef () + global-lincnt 59. + grindproperties '(expr fexpr value macro)) + (array gtab/| t 128.)) + + + +;;; (GRINDEF ...) +;;; Grinds the properties of the atoms listed on GRINDPROPERTIES. +;;; +;;; (GRINDEF ( ...) ...) +;;; grinds the additional properties as well. + +(defun grindef fexpr (atoms) + (let ((linel (grlinel)) (*rset grind*rset) (nouuo grind*rset)) + (prog (traced fn props) + (cond (atoms (setq grindef atoms)) + ((setq atoms grindef))) + (setq props grindproperties) + a (cond ((null atoms) (return '*))) + (setq fn (car atoms) atoms (cdr atoms)) + (cond ((atom fn) (and (not (symbolp fn)) (go a))) + ((setq props (append fn props)) (go a))) + ;;; flag for fn being traced + (cond ((setq traced (and (status feature trace) + (memq fn (trace)))) + (terpri) + (terpri) + (princ '/;traced))) + (do + ((plist (plist fn) (cddr plist)) + (ind 'value (car plist)) + (prop (and (boundp fn) (cons () (eval fn))) + (cadr plist)) + ;;; needed in case there are value properties + (valueless () 't)) + (()) + (cond ((and traced + ;;; ignore all but last if traced + (memq ind '(expr fexpr macro))) + (setq traced (get (cdr plist) ind)) + (go b)) + ;;; grindef only desired properties. + ((not (memq ind props)) (go b)) + ((eq ind 'value) + (cond ((and prop (not valueless)) + (terpri) + (terpri) + (sprint `(setq ,fn (quote ,(cdr prop))) + linel + 0.))) + (go b))) + (terpri) + ;;; terpri's placed here to avoid + (terpri) + ;;; lambda -> defun + (cond ((and (memq ind '(expr fexpr macro)) + (eq (car prop) 'lambda)) + (sprint (cons 'defun + (cons fn + (cond ((eq ind 'expr) + (cdr prop)) + ((cons ind + (cdr prop)))))) + linel + 0.)) + ((sprint `(defprop ,fn ,prop ,ind) + linel + 0.))) + b + ;;; exit from do when no more properties + ;;; look for more atoms to do. + (or plist (return ()))) + (go a)))) + +;;; (unformat fn1 fn2 ...) or (unformat (fn1 fn2 ...)) +;;; Removes grinding information from the each of a list of functions. + +(defun unformat fexpr (x) + (or (atom (car x)) (setq x (car x))) + (mapc '(lambda (x) (remprop x 'grindfn) + (remprop x 'grindmacro) + (remprop x 'grindpredict) + (remprop x 'gflatsize)) + x)) + +;;; eg (grindmacro quote /') + +(defun grindmacro fexpr (y) + (putgrind (car y) (cdr y) 'grindmacro)) + +;;; eg (grindfn (defun defmacro) def-form) + +(defun grindfn fexpr (y) + (putgrind (car y) (cdr y) 'grindfn)) + +;;; (PUTGRIND ) +;;; +;;; may be a function-name or a list of function-names +;;; (in which case, the operation will be distributed recursively +;;; across the list) +;;; +;;; must be a list. ... more documentation needed ... + +(defun putgrind (fn prop ind) + (cond ((atom fn) + (setq prop + (cond ((atom (car prop)) + (cond ((get (car prop) 'grindpredict) + (putprop fn + (get (car prop) 'grindpredict) + 'grindpredict))) + (car prop)) + ('t (cond ((eq (caar prop) 'readmacroinverse) + (putprop fn + (get 'readmacroinverse 'grindpredict) + 'grindpredict))) + (cons 'lambda (cons () prop))))) + (putprop fn prop ind)) + ('t (mapc '(lambda (x) (putgrind x prop ind)) fn)))) + + +;;; eg (readmacro quote /' ) +;;; where optional means grind CDR instead of CADR. + +(defun readmacro fexpr (y) + (putgrind (car y) + (list (cons 'readmacroinverse + (cons (cadr y) (cddr y)))) + 'grindmacro)) + +;;; remove readmacro info from a character + +(defun unreadmacro fexpr (y) (remprop y 'grindmacro)) + +;;; *** If you know what this does, please document it --kmp *** + +(defun grindmacrocheck (x l) + (cond ((or (atom x) (cdr x)) ()) + ((null (car x)) (= (length l) 2.)) ;x = (()) + ((equal (car x) '(t)) (cdr l)))) ;x = ((t)) + +;;; (readmacroinverse ) --> . +;;; Macro-char may be an atom or list of ascii values. +;;; Note that it expects the special variable L to have info about the +;;; form which is being printed. + +(defun readmacroinverse fexpr (x) + (prog (sprarg) + (cond ((cond ((null (cdr x)) (= (length l) 2.)) + ((and (null (cddr x)) (eq (cadr x) 't)) (cdr l))) + (cond ((atom (car x)) (princ (car x))) + ((mapc 'tyo (car x)))) + ;;; macro must have arg to execute inverse + (setq sprarg (cond ((null (cdr x)) (cadr l)) + ((eq (cadr x) 't) (cdr l)) + ((= (length (cdr l)) 1.) + (cond ((null (cadr l)) + (tyo #\space) + (return 't)) + ('t (cadr l)))) + ('t (cdr l)))) + (cond ((sprint1 sprarg (grchrct) m) + (prin1 sprarg))) + (return 't)) + ('t (return ()))))) + +;;; GATOMP - ATOM check for proper (?) handling of hunks. REES 4/2/80 +;;; Returns true for objects which should NOT be iteratively +;;; CDRed during analysis. + +(defun gatomp (x) + (or (atom x) + (and (hunkp x) hunkp hunksprin1))) + +;;; Format for LAMBDA and LET +;;; +;;; (name bvl body) if it all fits on one line. +;;; else (name bvl +;;; body) with 3 spaces indentation. +;;; + +(defun lambda-form () + (let ((obj (car l))) + (grindform 'line) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg (gflatsize obj))))) + (grindform 'block))) + + + +(eval-when (eval compile) (tyipeek 12.) ) ; skip debugging stuff + + ;; debugging only + +(defun beep-trace (X) + (let (((v . h) (cursorpos tyo))) + (tyo 7.) + (cursorpos 23. 50. tyo) + (princ'*) (princ x) + (cursorpos v h tyo) + (rubout(tyi)) + (cursorpos 23. 70. tyo) + (cursorpos'l tyo) + (cursorpos v h tyo))) + + + +(defun do-form () + (let ((c-ct (grchrct)) (c-ct2) (gflag 't)) +; (beep-trace 'do) + (grindform'line) + (setq c-ct2 (grchrct)) + (grindform'code) + (cond ((not (and gpredict (< (grchrct) (gflatsize (testl))))) + (setq gflag 't) + (indent-to c-ct2))) + (grindform'code) + (and gflag (indent-to c-ct)) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg 3.)))) + (setq prog? 't) + (grindform 'block))) + +; Experimental: -kmp +;(defun cond-form () +; (beep-trace 'cond) +; (let ((cct (- (grchrct) 5.))) +; (grindform'line) +; (cond ((not (and gpredict +; (< (grchrct) (gflatsize (testl))))) +; (do ((flag nil t)) ((done? cct)) +; (and flag (indent-to cct)) +; (grindform'code))) +; (t +; (grindform'block))))) +; +;(grindfn (cond) cond-form) + +;;; Format for PROG's +;;; prohibits form3 if args do not fit on line + +(defun prog-form () +; (beep-trace'prog) + (grindform 'line) + (setq prog? 't) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + (arg))) + (grindform 'block)) + + +;;; prohibits form3 if args do not fit on line + +(defun def-form () + (prog (c) + (setq c (car l)) + (grindform 'line) + (grindform 'line) + go (cond ((memq (testl) '(expr fexpr macro)) + (grindform 'line) + (go go))) + (setq grindform (cond ((and gpredict + (< (grchrct) (gflatsize (testl)))) + 'form2) + ('t (+ arg (gflatsize c))))) + (return (grindform 'block)))) + +;;; quoted second arg ground as block + +(defun mem-form () + (prog (p gm) + (grindform 'line) + (remsemi-tac) + (*catch () + (and (setq p (panmax (car l) (grchrct) 0.)) + (cond ((< (panmax (car l) n 0.) p)) + ((setq n (grchrct)))))) + (cond ((sprint1 (car l) n 0.) (prin1 (car l)))) + a (cond ((null (cdr l)) + (setq l (error 'mem-form l 'fail-act)) + (go a))) + (popl) + go (indent-to n) + (setq m (1+ m)) + (cond ((eq (caar l) 'quote) + (tyo #/') + (cond ((pprin (cadar l) 'block)) + ((prin1 (cadar l))))) + ((setq gm (sprint1 (car l) n m)) + (prin1 (car l)))) + (popl) + (cond (l (go go)) ((return ()))))) + +;;; standard form +;;; committed to at least standard form +;;; prediction in special form computed to +;;; compare to p. +;;; setq form + +(defun setq-form () + (cond ((*catch () + (prog (mm) + (setq mm (maxpan (cdr l) arg m)) + (setq n arg) + (defprop setq setq-predict grindpredict) + (and (< mm (panmax l (prog2 () (1+ n) + (setq n arg)) + m)) + (return 't)) + (grindform 'line) + d (or l (return ())) + (indent-to n) + (grindform 'line) + (grindform 'code) + (remsemi-tac) + (go d))) + ;;; SETQ-PREDICT causes throw when variable name is very long. + ;;; therefore, it is not used all the time but only inside + ;;; setq-form. + (defprop setq () grindpredict) + (grindform 'line) + (setq grindform n)))) + + + + + +;;; grinds l with args outputed as list. + +(defun comment-form () (gblock (- (grchrct) 1. (gflatsize (car l))))) + +(defun block-form () (gblock (grchrct))) + + + +(declare (unspecial l n m)) + +;;; returns number of lines to print args +;;; as name-value pairs. +;;; n = space for namevalue. 2 = +;;; space for ( and . +;;; nn = space for value. 2 = space for ) +;;; and . + +(defun setq-predict (l n ()) ; m omitted -- not used + (prog (mm nn) + (setq n (- n 2. (gflatsize (car l)))) + (setq mm 0.) + a (and (null (setq l (cdr l))) (return mm)) + (and (semi? (car l)) (go a)) + (setq nn (- n 2. (gflatsize (car l)))) + b (cond ((null (cdr l)) + (setq l (error 'setq-predict l 'wrng-no-args)) + (go b))) + (setq l (cdr l)) + (and (semi? (car l)) (go b)) + (setq mm (+ mm (panmax (car l) nn 0.))) + (go a))) + +(declare (special l n m)) + +;;;format control + +;;; (gpredict) <=> (gpredict t) => super-careful +;;; sprint considering all formats. (gpredict ()) +;;; => less careful but quicker. + +(defun gpredict args (setq gpredict (cond ((= args 0.)) ((arg 1.))))) + + ;;don't clobber user def. this is for compatibility only +(cond ((not (fboundp 'predict)) + (defprop predict gpredict expr))) + + +(defun programspace (x) + (setq programspace (setq linel x)) + (setq comspace (- pagewidth gap programspace))) + +(defun pagewidth (w x y z) + (setq pagewidth w) + (setq gap y) + (setq programspace (setq linel x)) + (setq comspace z)) + +(defun comspace (x) + (setq comspace x) + (setq programspace (setq linel (- pagewidth gap comspace)))) + +;;; (grindfill) <=> (grindfill t) => spaces gobbled in ; + +(defun grindpage () (tyo #\formfeed) (setq grindlinct global-lincnt)) + +;;; comments. (grindfill ()) => spaces not gobbled. +;;; triple semi comments are never filled but are +;;; retyped exactly inuser's original form. + +(defun grindfill args (setq grindfill (cond ((= args 0.)) ((arg 1.))))) + +;;; (grindmerge) <=> (grindmerge t) => adjoining ; and ;; +;;; comments are merged. (grindmerge ()) => adjoining +;;; comments not merged. ;;;... are never merged. + +(defun grindmerge args (setq grindmerge (cond ((= args 0.)) ((arg 1.))))) + +;;; (user-paging) <=> (user-paging t) +;;; grind does not insert any formfeeds, but +;;; preserves paging of user's file. (user-paging +;;; () ) => grind inserts formfeed every 59 lines. +;;; attempts to avoid s-expr pretty-printed over +;;; page boundary. ignores users paging. paging of +;;; user's file. + +(defun user-paging args + (setq user-paging (cond ((= args 0.)) ((arg 1.))))) + +(defun topwidth (x) (setq topwidth x)) + +;;; REMSEMI must be non-() + +(defun remsemi () + (do ((fl)) + ((cond ((rem/;) (rem/;/;) (setq fl 't) ()) + ((rem/;/;) (setq fl 't) ()) + ('t)) + fl))) + +;;; check for any ;;'s +;;; at any depth + +(defun semisemi? (k) + (cond ((null remsemi) ()) + ((eq k /;/;)) + ((gatomp k) ()) + ((or (semisemi? (car k)) (semisemi? (cdr k)))))) + +(defun semi? (k) (and remsemi (or (eq (car k) /;) (eq (car k) /;/;)))) + + +;;; indents additonal nn spaces. + +(defun indent (nn) + (cond ((minusp (setq nn (- (grchrct) nn))) + (error 'indent/ beyond/ linel? nn 'fail-act) + (terpri)) + ((indent-to nn)))) + + +;;; chrct set to nn +;;; chrct may become negative from +;;; prin50com. +;;; some indentation is necessary +;;; position as a result of first tab. +;;; tabs do not move 8, but +;;; to nearest multiple of 8 + +(defun indent-to (nn) + ((lambda (nct tab) + (declare (fixnum nct tab)) + (cond ((or (< nct 0.) (> nn nct)) + (turpri) + (setq nct linel))) + (cond ((< nn nct) + (setq tab (+ nct + (- (stat-tab)) + (\ (- linel nct) (stat-tab)))) + (cond ((< tab nn) (grindslew (- nct nn) #\space)) + ((tyo #\tab) + (setq nct tab) + (cond ((< nn nct) + (setq nct (- nct nn)) + (grindslew (// nct (stat-tab)) + #\tab) + (grindslew (\ nct (stat-tab)) + #\space)))))))) + (grchrct) + 0.)) + +(defun grindslew (nn x) (do mm nn (1- mm) (zerop mm) (tyo x))) + +;;; this global variable records whether the last +;;; form printed was a double-semi comment. if so, +;;; it is non-() and rem/;/; merges the current +;;; comment. this meging should not happen across +;;; a pprin. furthermore, it is a bug if pprin is +;;; printing code that is an atom. then /;/;? is +;;; not set to () and it falsely indicates tha the +;;; last form printed was a /;/; comment. l is +;;; = 'block or as a function followed by a list +;;; ground as line if tp = 'line, as a block if tp +;;; of arguments if l = 'list, or normally +;;; if tp = 'code. + +(defun pprin (l tp) + (setq /;/;? ()) + (cond ((atom l) (prin1 l) 't) + ((eq tp 'line) (cond ((gprin1 l n) (prin1 l))) 't) + ((eq tp 'block) + (or (and (symbolp (car l)) + ((lambda (x) (and x (apply x ()))) + (get (car l) 'grindmacro))) + (progn (princ '/() + (gblock (grchrct)) + (princ '/))))) + ((eq tp 'list) + (or (and (symbolp (car l)) + ((lambda (x) (and x (apply x ()))) + (get (car l) 'grindmacro))) + (progn (princ '/() + (gblock (- (grchrct) 1. (gflatsize (car l)))) + (princ '/))))) + ((eq tp 'code) (sprint1 l (grchrct) m) 't))) + + + +;;; cr with line of outstanding single semi +;;; comment printed, if any. grindlinct = +;;; lines remaining on page. + +(defun turpri () + (and remsemi comnt (prin50com)) + (terpri) + (setq grindlinct (cond ((= grindlinct 0.) global-lincnt) + ((1- grindlinct))))) + +;;; (grchrct) +;;; Returns the amount of room between the current horizontal position +;;; and the end of the line. For many applications, this is the right +;;; second arg to give to sprint1 on recursive pretty-print dives. + +(defun grchrct () + (- linel (charpos (car (or (and ^R outfiles) '(t)))))) + +;;; (grlinel) +;;; This is the linel of the output file that we are presumably grinding to + +(defun grlinel () + (cond ((boundp 'grlinel) grlinel) + ('t (linel (car (or (and ^R outfiles) '(t)) ))))) + +;;; KMP: Note -- this function is hairier than it needs to be. In current +;;; GFN and GFILE, it is ALWAYS called with no args. Somebody who is +;;; awake at the time should try to simplify it into something readable +;;; and/or scrap this package entirely and write something winning. + +(defun testl args + (prog (k nargs) + (setq k l nargs (cond ((= 0. args) 0.) ((arg 1.)))) + a (cond ((null k) (return ())) + ((semi? (car k)) (setq k (cdr k)) (go a)) + ((= 0. nargs) + (return (cond ((= 2. args) k) ('t (car k))))) + ((setq nargs (1- nargs)) + (setq k (cdr k)) + (go a))))) + +;;; pprin the car of l, then pops l. +;;; no-op if l is already (). process +;;; initial semi-colon comment, if any, +;;; then try again. pretty-print c(car l) +;;; in desired format. if l is not yet (), output +;;; a space. return popped l. + +(defun grindform (x) + (cond ((remsemi-tac) (grindform x)) + (l (cond ((pprin (car l) x) + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (setq l (cdr l))) + ('t (prin1 (car l)) + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (setq l (cdr l))))))) + +;;; pretty print over whole width + +(defun sprinter (l) + (let ((linel (grlinel)) (*rset grind*rset) (nouuo grind*rset)) + (turpri) + (turpri) + (sprint l linel 0.) + (turpri) + '*)) + +;;; For efficiency, the symbol SPRIN1 is a substitution alist for the +;;; function SPRIN1 to use. This actually does the wrong thing if TYO is +;;; rebound to something else, but fooey on people that do that. + +(setq sprin1 `((T . ,tyo))) + +;;; (SPRIN1 object [ optional-file-info ]) +;;; pretty-prin1's object to files specified or default output file if +;;; none given explicitly. No initial carriage return is typed by SPRIN1 +;;; so the form is displayed properly indented for the current horizontal +;;; position. + +(defun sprin1 (ll &OPTIONAL (files outfiles)) + (let ((*rset grind*rset) + (nouuo grind*rset) + (linel (grlinel)) + (^r 't) + (^w ^w) + (outfiles (progn (cond ((not files) ()) + ((atom files) (setq files (ncons files)))) + (sublis sprin1 files)))) + (and files (setq ^w 't)) + (sprint ll (grchrct) 0) + 't)) + +;;; This is the correct toplevel function to call when sprin1'ing a function. +;;; Clears the hash table and then calls sprint1. sprint1 is the correct +;;; function to recursively call. see doc on sprin1 for info on what the +;;; args l, m, and n do. + +(defun sprint (l n m) + (fillarray 'gtab/| '(())) + (sprint1 l n m)) + +;;;sprint formats +;;;form1 = (s1 form2 = (s1 s2 form3 = (s1 s2 (sprint1 last)) +;;; s2 s3) +;;; s3) + +;;; expression l to be sprinted in space n +;;; with m unbalanced "/)" hanging. p is +;;; number lines to sprint1 as form2 +;;; this is an explicit check for quote. +;;; the alternative is to use the standard +;;; grindmacro to use your own personal readmacro +;;; for quote, setq grind-standard-quote to (). +;;; if a ;; comnt, force multi-line +;;; +;;; p = # of lines to sprint l in standard + +(defun sprint1 (l n m) + (prog (grindform arg fn args p prog? grindfn form3? gm) + (and (remsemi-tac) (null l) (return ())) + (setq /;/;? ()) + (indent-to n) + (cond ((gatomp l) + (cond ((atom l) (prin1 l)) + ('t (funcall hunksprin1 l n m))) + (return ()))) + (cond ((and grind-standard-quote + (not (and hunkp + hunksprin1 + (hunkp l))) + (eq (car l) 'quote) + (cdr l) + (null (cddr l))) + (princ '/') + (setq gm (sprint1 (cadr l) (grchrct) m)) + (return ()))) + (and (symbolp (car l)) + (setq fn (car l)) + (let ((x (get fn 'grindmacro))) + (and x (apply x ()))) + (return ())) + (cond ((semisemi? l)) + ((< (+ m -1. (gflatsize l)) (grchrct)) + (return (gprin1 l n)))) + (princ '/() + (setq n (grchrct)) + (setq arg (- n (gflatsize (car l)) 1.)) + (and + (atom (setq args + (cond ((setq grindfn (get fn + 'grindfn)) + (apply grindfn ()) + (and (numberp grindform) + (setq n grindform) + (go b)) + (and (null l) + (princ '/)) + (return ())) + l) + ((cdr l))))) + (go b)) + ;; catch exited if space insufficient. + (*catch () + (and + (setq p (maxpan args arg m)) + ;;; Format. Exit if miser more efficient than standard + ;;; in no-predict mode, use miser format on all non-fn-lists. + (cond (gpredict (not (< (maxpan args n m) p))) + (fn)) + (setq n arg) + ;;; committed to standard format. + (cond + (grindfn (or (eq grindform 'form2) + (> (maxpan args (grchrct) m) p) + (setq n (grchrct)))) + ((prog () + ;;; skip form3 is gpredict=(). + (or gpredict (go a)) + (*catch () + ;;; l cannot be fit in chrct is it more + ;;; efficient to grind l form3 or form2 + (setq + form3? + (and (not (eq (car (last l)) /;)) + (< (maxpan (last l) + (- (grchrct) + (- (gflatsize l) + (gflatsize (last l)))) + m) + p)))) + a (setq gm (gprin1 (car l) n)) +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 always returns () nowadays. +;;; This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (gprin1 (car l) n)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- n 2.)) +;;; (setq l ()) +;;; (go b1)) +;;; (t (prin1 (car l)))))) +;;; + (cond ((and (cdr l) + (not (and hunkp + hunksprin1 + (hunkp (cdr l))))) + (tyo #\space))) + (and (cdr (setq l (cdr l))) form3? (go a)) + b1 (setq n (grchrct))))))) + b (grindargs l n m))) + +;;; hunk L to be sprinted in space N with M unbalanced /)'s hanging... + +(defun standard-hunksprin1 (l n m) + (cond ((< (gflatsize l) (- n m)) + (standard-hunkprin1 l n m)) + ('t + (princ '|(|) + (do ((i 1. (1+ i)) + (m+3 (+ 3 m)) + (width (grchrct)) + (size (hunksize l))) + ((= i size) + (indent-to n) + (sprint1 (cxr 0. l) width m+3) + (princ '| .)|)) + (cond ((> i 1) (indent-to n))) + (sprint1 (cxr i l) width m+3) + (princ '| . |))))) + +(defun (standard-hunksprin1 hunkgflatsize) (x) + (declare (fixnum i s w)) + (do ((i 0. (1+ i)) + (s (hunksize x)) + (w 1. (+ w 3. (gflatsize (cxr i x))))) + ((= i s) w))) + +(defun standard-hunkprin1 (l n m) + (princ '|(|) + (do ((i 1. (1+ i)) + (m+3 (+ 3 m)) + (size (hunksize l))) + ((= i size) + (sprint1 (cxr 0. l) (grchrct) m+3) + (princ '| .)|)) + (sprint1 (cxr i l) (grchrct) m+3) + (princ '| . |))) + +;;; elements of l are ground one under the +;;; next +;;; prints closing paren if done. +;;; exception of tags which are unindented +;;; 5 + +(defun grindargs (l nn mm) + (prog (gm sprarg1 sprarg2) + a (and (done? nn) (return ())) + (setq sprarg1 + (cond ((and prog? + (car l) + (atom (car l))) + (+ nn 5.)) + (nn))) + (setq sprarg2 (cond ((null (cdr l)) (1+ mm)) + ((atom (cdr l)) + (+ 4. mm (gflatsize (cdr l)))) + (0.))) + (setq gm (sprint1 (car l) sprarg1 sprarg2)) + +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 and SPRINT1 always return () +;;; nowadays. This may not be the right thing -- they may not want +;;; to always return (), but this code will never get reached in the +;;; current state of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (sprint1 (car l) sprarg1 sprarg2)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (sprint1 l (- sprarg1 2.) sprarg2) +;;; (setq l ()) +;;; (go a)) +;;; (t (prin1 (car l)))))) +;;; + + (setq l (cdr l)) + (go a))) + +;;; if previous line a ;; comment, then do +;;; not print closing paren on same line as +;;; comment. +;;; prints closing "/)" if done + +(defun done? (nn) + (cond ((gatomp l) + (and /;/;? (indent-to nn)) + (cond (l (princ '/ /./ ) + (cond ((> (gflatsize l) (grchrct)) ; for hunks + (indent-to nn))) + (sprint1 l (grchrct) m))) + (princ '/)) + 't))) + + +;;; l printed as text with indent n. + +(defun gblock (n) + (prog (gm) + (and (remsemi-tac) (or l (return ()))) + a (cond ((gatomp l) + ;;; Hunks used to not get middle shown by grind. For + ;;; people that might have used this feature, we won't + ;;; treat hunks specially if HUNKSPRIN1 is not set to + ;;; the name of a printer. + (princ '|. |) + (prin1 l) + (return ())) + ((setq gm (gprin1 (car l) n)) + ;;; Result Omitted -- See below + )) + +;;; +;;; KMP: The previous COND used to have a consequent to its last clause, but +;;; since GPRIN1 always returns () nowadays, I have factored out that +;;; part. This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; ((setq gm (gprin1 (car l) n)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- n 2.)) +;;; (return (setq l ()))) +;;; (t (prin1 (car l))))) +;;; + + (or (popl) (return ())) + (cond ((< (gflatsize (car l)) (- (grchrct) 2. m)) + (tyo #\space) + (go a)) + ;;; non-atomic elements occuring in block + ;;; too large for the line are sprinted. + ;;; this occurs in the variable list of a prog. + ((and (not (atom (car l))) ;GATOMP? + (< (- n m) (gflatsize (car l)))) + (cond ((setq gm (sprint1 (car l) n m)) + ;;; KMP: I think this code can never be reached. + ;;; It looks like SPRINT1 always returns () + ;;; since it looks like GPRIN1 does too... + ;;; Can someone check me on this? Tnx. + (cond ((grindmacrocheck gm l) + (princ '/./ ) + (sprint1 l (- n 2.) m) + (return (setq l ()))) + ('t (prin1 (car l)))))) + (or (popl) (return ())))) + ;;; new line + (indent-to n) + (go a))) + +;;; prin1 with grindmacro feature. + +(defun gprin1 (l nn) + (cond ((gatomp l) + (cond ((hunkp l) (funcall hunksprin1 l nn m)) + ('t (prin1 l))) + ()) + ((prog (gm) + (remsemi-tac) + (and (atom (car l)) + (let ((x (get (car l) 'grindmacro))) + (and x (apply x ()))) + (return ())) + (princ '/() + (setq nn (1- nn)) + a (setq gm (gprin1 (car l) nn)) + +;;; +;;; KMP: The previous setq used to be the COND commented out here. I stripped +;;; the COND off the outside because GPRIN1 always returns () nowadays. +;;; This may not be the right thing -- GPRIN1 may not want to always +;;; return (), but this code will never get reached in the current state +;;; of things, so it might as well not get compiled in. +;;; +;;; (cond ((setq gm (gprin1 (car l) nn)) +;;; (cond ((grindmacrocheck gm l) +;;; (princ '/./ ) +;;; (gprin1 l (- nn 2.)) +;;; (setq l ()) +;;; (go a1)) +;;; (t (prin1 (car l)))))) +;;; + + (popl) + a1 (and (done? nn) (return ())) + (tyo #\space) + (go a))))) + + + +(comment Special grind functions for system-related facilities) + + +;;; For use with "macroexpanded" forms + +(defun |MACROEXPANDED-grindmacro/|| () + (declare (special l m)) + (sprint1 (cond (grind-macroexpanded (nth 4 l)) ((nth 3 l))) + (grchrct) + m) + 't) + +;;; For help with "backquote" forms +;;; +;;; KMP: This function is put on the GRINDMACRO property of |`-expander/|| +;;; et al when the BACKQ package gets loaded. If you ask me, it should +;;; get set up at the time this package loads. + +(defun |+INTERNAL-`-grindmacros/|| () + (declare (special l m)) + (eval (cons 'readmacroinverse + (cdr (assq (car l) + '((|`-expander/|| |`| t) + (|`,/|| |,| t) + (|`,@/|| |,@| t) + (|`,./|| |,.| t)))))) + 't) + + + +;;prediction functions + +(declare (unspecial l n m)) + +;;;for increased speed, l n m are made unspecial in maxpan and panmax +;;; list of s expression one under the next +;;; estimates number of lines to sprint1 +;;; in space n + +(defun maxpan (l n m) + (declare (fixnum g)) + (prog (g) + (setq g 0.) + a (setq g + (+ g + (panmax (car l) + n + (cond ((null (setq l (cdr l))) (1+ m)) + ((gatomp l) (+ m 4. (gflatsize l))) + (0.))))) + (and (gatomp l) (return g)) + (go a))) + +;;; estimates number of lines to sprint1 an +;;; s expression in space n. less costly +;;; than sprint as prediction always chooses form2. +;;; if insufficient space, throws. + +(defun panmax (l n m) + (cond ((< (+ m -1. (gflatsize l)) n) 1.) + ((or (< n 3.) (atom l)) + (*throw () 40.)) ;should these "atom"s be + ((or (not (atom (car l))) (gatomp (cdr l))) ;"gatomp"'s? + (maxpan l (sub1 n) m)) + (((lambda (x) (and x (funcall x l n m))) + (get (car l) 'grindpredict))) + ((maxpan (cdr l) (- n 2. (gflatsize (car l))) m)))) + +(defun prog-predict (l n m) + ((lambda (nn) (+ (block-predict (cadr l) nn 1.) + (maxpan (cddr l) nn m))) + (- n 2. (gflatsize (car l))))) + +(defprop lambda-form prog-predict grindpredict) + +(defprop prog-form prog-predict grindpredict) + +;;; indent=spaces indented to margin of +;;; block. throw if insuff remaining space. +;;; number of lines approx by dividing size of l by +;;; block width. + +(defun block-predict (l n indent) + (cond ((> 1. (setq n (- n indent))) (*throw () 50.)) + ((1+ (// (- (gflatsize l) indent) n))))) + +;;; m not used. + +(defun block-predictor (l n () ) (block-predict l n 1.)) ; m = unused 3rd arg + +(defprop block-form block-predictor grindpredict) + +;;; m not used by block-predict. third arg +;;; represents indentation of block. + +(defun comment-predict (l n () ) ; m = unused 3rd arg + (block-predict l n (+ (gflatsize (car l)) 2.))) + +(defprop comment-form comment-predict grindpredict) + +(defun readmacroinverse-predict (l n m) + (panmax (cadr l) + (- n (cond ((atom (car l)) (flatc (car l))) + ('t (length (car l))))) + m)) + +(defprop readmacroinverse readmacroinverse-predict grindpredict) + + + +(declare (special l n m)) + +;;; user read macros. +;;; (eg (slashify $)). preserve slashes preceding + +(defun slashify fexpr (chars) (mapc 'slashify1 chars)) + +(defun unslashify fexpr (chars) (mapc 'unslashify1 chars)) + +;;; make char '-like readmacro. +;;; will be null only if char is single + +(defun slashify1 (char) + ((lambda (readtable) + (or (null (getchar char 2.)) + (setq char (error 'slashify + char + 'wrng-type-arg))) + (setsyntax char + 'macro + (subst char + 'char + '(lambda () (list 'char + (read))))) + (apply 'readmacro (list char char))) + grindreadtable)) + +(defun unslashify1 (char) + ((lambda (readtable) (or (null (getchar char 2.)) + (setq char + (error 'unslashify + char + 'wrng-type-arg))) + (setsyntax char 'macro ()) + (apply 'unreadmacro (list char))) + grindreadtable)) + + + +;;;(defun gflatsize (data) +;;; ((lambda (nn bucket) +;;; (setq bucket (gtab/| nn)) +;;; (cdr (cond ((and bucket (assq data bucket))) +;;; (t (car (store (gtab/| nn) +;;; (cons (setq data +;;; (cons data +;;; (flatsize data))) +;;; bucket))))))) +;;; (\ (ghash data) 127.) +;;; ())) + +(defun gflatsize (data) + ((lambda (nn bucket) + (setq bucket (gtab/| nn)) + (cdr (cond ((and bucket (assq data bucket))) + ('t (car (store (gtab/| nn) + (cons (setq data + (cons data + (gflatsize1 data 't))) + bucket))))))) + (\ (ghash data) 127.) + ())) + +(defun +internal-dwim-predictfun (l n ()) + (cond ((> (gflatsize1 l 't) n) (*throw () 40.)) + ('t 1.))) + +;;; (GFLATSIZE1 L FLAG) +;;; This is a hook into the gflatsize process that says that we want L's +;;; + +(defun gflatsize1 (l flag) + (cond ((gatomp l) + (let ((fsize-fun (and (hunkp l) + (get hunksprin1 'hunkgflatsize)))) + (cond (fsize-fun (funcall fsize-fun l)) + ('t (flatsize l))))) + ((and flag + (symbolp (car l)) + (let ((fsize-fun (get (car l) 'grindflatsize))) + (cond (fsize-fun + (funcall fsize-fun l)))))) + ('t + (do ((len 2. (+ len + (gflatsize1 (car ll) 't) + (cond ((eq l ll) 0.) ('t 1.)))) + (ll l (cdr ll))) + ((gatomp ll) + (cond ((null ll) len) + ('t (+ len 3. + (let ((fsize-fun (and (hunkp ll) + (get hunksprin1 + 'hunkgflatsize)))) + (cond (fsize-fun + (funcall fsize-fun ll)) + ('t (flatsize ll)))))))))))) + +(defun gflatsize=1+cdr (l) + (1+ (gflatsize1 (cdr l) 't))) + +(defun gflatsize=2+cdr (l) + (+ (gflatsize1 (cdr l) 't) 2.)) + +(defprop |`-expander/|| gflatsize=1+cdr grindflatsize) +(defprop |`,/|| gflatsize=1+cdr grindflatsize) +(defprop |`,@/|| gflatsize=2+cdr grindflatsize) +(defprop |`,./|| gflatsize=2+cdr grindflatsize) + +(defun (/' grindflatsize) (l) + (cond ((and grind-standard-quote (= (length l) 2.)) + (+ 1. (gflatsize1 (cadr l) 't))) + ((+ 8. (gflatsize1 (cdr l) ()))))) + +(mapc (function + (lambda (x) + (putprop x '+internal-dwim-predictfun 'grindpredict))) + '(quote |`-expander/|| |`,/|| |`,@/|| |`,./||)) + + + +;;; default formats +;;; still need to define the standard macro + +(readmacro quote /') + +(grindfn (grindfn grindmacro) (grindform 'line) + (grindform 'block)) + + ;; let needs its own thing... +(grindfn (lambda eval-when) lambda-form) + +(grindfn (do) do-form) + + ;; caseq needs to do something much like def-form +(grindfn (defun defun/& defmacro) def-form) + +(grindfn prog prog-form) + +(grindfn (comment remob **array *fexpr *expr *lexpr special unspecial fixnum flonum) comment-form) + +(grindfn (member memq map maplist mapcar mapcon mapcan mapc assq + assoc sassq sassoc getl fillarray) mem-form) + +(grindfn setq setq-form) +(grindfn setf setq-form) + +(gpredict ()) + +;;;the following default formats are relevant only to grinding files. +;;;however, they appear here since the format fns are not defined +;;;in gfile and gfn is not loaded until after gfile. +;;default formats + +(pagewidth 112. 70. 1. 41.) + +(topwidth 110.) + +(grindmerge 't) + +(grindfill 't) + +(user-paging ()) + + + +;;; The GRINDREADTABLE is tailored for grind. + +((lambda (m) + (and (or (not (boundp 'grindreadtable)) + (null grindreadtable)) + ((lambda (readtable) + ;;; ^L made noticeable. + (setsyntax 12. 'single ()) + ;;; No auto cr. are inserted by lisp when + (sstatus terpri 't) + (setsyntax '/; + 'splicing + 'semi-comment)) + (setq grindreadtable + (*array () + 'readtable + grind-use-original-readtable)))) + + (cond ((or m (status feature maclisp)) + (let ((grindform (status userid)) + (comnt (cond ((status status homed) (status homed)) + ((status udir)))) + (defaultf defaultf) + l h) + (setq h (cons (list 'dsk comnt) + (cond ((status feature its) + (cons grindform '(grind))) + ('(grind ini))))) + (cond ((cond ((setq l (probef h))) + ((status feature its) + (rplaca (cdr h) '*) + (and + ((lambda (errset) + (setq l + (car + (errset + (funcall + (cond ((status feature sail) + 'eopen) + ('open)) + h + '(nodefault)) + () )))) + ()) + (setq l (truename l))) + l)) + (or (status feature noldmsg) + (prog2 (princ '|Loading GRIND init file| msgfiles) + (terpri msgfiles))) + (and + (atom (errset (funcall (cond ((status feature sail) + 'eload) + ('load)) + l) + 't)) + (princ '| *** ERRORS DURING LOADING *** BEWARE!| + msgfiles)))))) + ;;; loader for start_up.grind file + ('t (errset (load (list (status udir) + 'start_up + 'grind)) + ())))) + (status feature its)) + +(sstatus feature grindef) + +;;;;;;;;;;;;;;;;;;;;;; Bug Notes // Feature requests ;;;;;;;;;;;;;;;;;;;;; +;;; +;;; [ALAN (07/29/80)] Re: GRINDEF +;;; GRINDEF, SPRIN1 and friends don't seem to understand about +;;; (SSTATUS USRHU ...) etc. +;;; +;;; [KMP (09/23/80)] Re: GRINDEF +;;; The variable GRINDEF should be SETQ-IF-UNBOUND'd or something like that +;;; rather than just SETQ'd when the GRIND package loads. +;;; +;;; [ALAN (09/26/80)] Re: Old Style DO +;;; ... why don't you make it understand old-style DO? +;;; +;;; [SOLEY (09/26/80)] Re: GRINDEF +;;; In NILE;DOC >, the function DOCUMENTOR grinds terribly. +;;; +;;; [ALAN (09/29/80)] Re: Old-Style DO +;;; Date: 29 September 1980 1115-EDT (Monday) +;;; From: Guy.Steele at CMU-10A +;;; Recall that one can always convert old-style DO to new-style +;;; simply by inserting six parentheses: +;;; (DO X INIT STEP TEST BODY) => (DO ((X INIT STEP)) (TEST) BODY) +;;; SO a quick way out is just to grind every old-style DO as a new-style +;;; one, by this conversion (this amounts to an implicit declaration of war +;;; against old-style DO as being obsolete). +;;; I'm not sure I really advocate this -- just pointing out the +;;; possibility. +;;; ----- +;;; barf +;;; +;;; [Source: BEN@ML (09/24/80)] Re: GRIND mangles end-of-line comments +;;; In TOPS-10 MACLISP at Tufts (though I suspect elsewhere, too), GRINDing +;;; a file that includes end-of-line comments frequently puts the comments on +;;; the following line, unprotected by semi-colons. When this is loaded into +;;; LISP, we get lots of undefined value errors. (At installations that could +;;; run EMACS, no one would have to run GRIND, but . . .) Ben +;;; +;;; [Source: KMP,SRF,DANIEL (09/19/80)] Re: GRINDEF/TRACE interaction +;;; (DEFUN F (X) X) ; Define a function +;;; (GRINDEF F) ; Grinds just fine +;;; (TRACE F) ; Traces just fine +;;; (GRINDEF F) ; Grinds just fine with note that it's traced +;;; (DEFUN F (Y) Y) ; Redefine without untracing +;;; (GRINDEF) ; Claims traced. Doesn't grind +;;; (UNTRACE F) ; Untrace doesn't break the F(y) definition +;;; (GRINDEF F) ; Grinds just fine as F(y) +;;; ----- +;;; If there is a more recent definition than the traced definition, GRINDEF +;;; should allow that definition to supersede the trace information. +;;; +;;; [Reply-To: HMR, RWK, REES] Vectors +;;; Context: XNIL of 03/17/80 +;;; (defun foo (x) #(A B)) +;;; FOO +;;; (grindef foo) +;;; DEFUN FOO (X) # +;;; (A)) +;;; * +;;; ; Missing paren, broken over line +;;; +;;; [CWH] Re: TYO +;;; Make (TYO 100) => (TYO #/@), (TYO 11) as (TYO #\TAB), etc. +;;; +;;; [PRATT (3/18/80)] Re: ##MORE## +;;; Is grindef supposed to work correctly in conjunction with the standard +;;; more-processing? It seems like it gets confused about whether an +;;; s-expression will fit on the current line when that line follows ##MORE##. +;;; +;;; The following functions need special grind handlers -- +;;; DEFMACRO, CASEQ (Maybe like LAMBDA? -JAR), DEFUN& (-RLB), SETF (-RWK) +;;; +;;; #PRINT / GPRINT +;;; Waters' printer lives in LIBLSP;GPRINT. See LIBDOC;GPRINT for details. +;;; DICK;LSPMP QFASL is a version of GPRINT which will run on the LispMachine. +;;; +;;; [Reply-To: BKERNS (05/22/80)] Re: Prin{level/length} +;;; How hard would it be to make the grinder know about prinlength and +;;; prinlevel? I'm in desperate need of such a feature. +;;; +;;; [Reply-To: ALAN (06/28/80)] Re: GRINDEF +;;; ... since we will continue to support old-style DO can we please have it +;;; grind properly? Please?? ... +;;; +;;; [Reply-To: RLB (06/29/80)] Re: GRINDEF (In-Reply-To: ALAN's note) +;;; Seconded by me. Language redesign shouldn't happen defacto by causing +;;; constructs which you find distasteful to become otherwise distasteful to +;;; others. Is this paranoia or unusual perceptiveness? +;;; +;;; [Reply-To: ALAN (09/18/80)] Re: GRINDEF +;;; Is anybody EVER going to fix grindef to understand old-style do? +;;; +;;; *** Don't forget crlf after this line! *** + diff --git a/src/lspsrc/querio.51 b/src/lspsrc/querio.51 new file mode 100755 index 00000000..19a06110 --- /dev/null +++ b/src/lspsrc/querio.51 @@ -0,0 +1,213 @@ +;;; QUERIO -*-Mode:Lisp;Package:SI-*- +;;; ************************************************************************** +;;; ***** MACLISP ****** Build a Bi-directional SFA for Queries to User ****** +;;; ************************************************************************** +;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology ******** +;;; ************ this is a read-only file! (all writes reserved) ************* +;;; ************************************************************************** + + +(herald QUERIO /51) + + +(include ((lisp) subload lsp)) + +(eval-when (eval compile) + (subload UMLMAC) + ) + + +;; Used also by CERROR file +(defun si:FRESH-LINIFY (stream) + (if (and (sfap stream) + (memq 'FRESH-LINE (sfa-call stream 'WHICH-OPERATIONS () ))) + ;; If the command can be "passed down", then do so + (sfa-call stream 'FRESH-LINE () ) + ;; Otherwise, just try a cursorpos 'A. + (cursorpos 'A stream))) + +(defun si:SPREAD-CURSORPOS (data out) + (caseq (length data) + (0 (cursorpos out)) ;0 extra arg: Read pos + (1 (cursorpos (car data) out)) ;1 more arg : Hac some + (T (cursorpos (car data) (cadr data) out)) ; Set pos + )) + + + +(defvar SI:QUERY-IO-EXTRA-OPTIONS () + "Used to communicate to the SFA-function whether or not there are + certain methods in the real file arrays (CURSORPOS, RUBOUT, ??)") +(defvar SI:QUERY-IO-NEW-LISP (ALPHALESSP "2090" (STATUS LISPV))) + + +(defun GEN-QUERY-SLOTS macro (l) + (pop l) + (setq no-of-QUERY-IO-slots (length l)) + `(PROGN 'COMPILE + ,.(do ((ll l (cdr ll)) (i 0 (1+ i)) (z)) + ((null ll) z) + (push `(DEFUN ,(symbolconc '|QUERY-IO-| (car ll)) MACRO (X) + `(SFA-GET ,(CADR X) ,,i)) + z)))) + + ;; makes things like (defmacro QUERY-IO-input (x) `(SFA-GET ,x 1)) +(gen-query-slots output input omode imode whichops putbacklist) + +(defun BI-DIRECTIONAL-CORRESPONDENT macro (x) `(SFA-GET ,(cadr x) 'XCONS)) + +(defun cons-a-QUERY-IO macro (l) + (pop l) + (let ((x (or (get l 'IN) + '(IF (STATUS STATUS TTYIFA) (STATUS TTYIFA) TYI))) + (y (get l 'OUT)) + z setout in out) + (si:gen-local-var in "in") + (si:gen-local-var out "out") + (si:gen-local-var z) + (setq setout `(SETQ ,out (STATUS TTYCONS ,in))) + (if y (setq setout `(OR ,out ,setout))) + `(LET ((,in ,x) (,out ,y) ,z) + ,setout + (SETQ SI:QUERY-IO-EXTRA-OPTIONS + (APPEND (CDR (STATUS FILEMODE ,out)) + ;; FILEPOS currently only gets you the output data + (DELQ 'FILEPOS (APPEND (CDR (STATUS FILEMODE ,in)) () )))) + (SETQ ,z (SFA-CREATE 'QUERY-IO-HANDLER ,no-of-QUERY-IO-slots 'QUERY-IO)) + (SETF (QUERY-IO-input ,z) ,in) + (SETF (QUERY-IO-output ,z) ,out) + (SETF (QUERY-IO-omode ,z) (STATUS FILEMODE ,out)) + (SETF (QUERY-IO-imode ,z) (STATUS FILEMODE ,in)) + ;; For newer lisps, this permits the LISP toplevel routines to know + ;; that it's a bi-directional device, and probably the echo of a + ;; inputted will suffice instead of also doing a (TERPRI). + (AND SI:QUERY-IO-NEW-LISP + (SETF (BI-DIRECTIONAL-CORRESPONDENT ,z) ,z)) + ,z))) + + + + +(defun QUERY-IO-HANDLER (self op data &aux (in (QUERY-IO-input self)) + (out (QUERY-IO-output self)) + (bufl (QUERY-IO-putbacklist self))) + (cond + ((eq op 'UNTYI) + ;; For old lisps, without the UNTYI function, we support UNTYI by just + ;; keeping a list of the characters sent back. Note that we could + ;; support a msg to store and retrieve this slot, and thus facilitate + ;; a user writing a TTYBUFFER function which could keep separate from + ;; the base-level TYI. + (if (not SI:QUERY-IO-NEW-LISP) + (setf (QUERY-IO-putbacklist self) (cons data bufl)) + (untyi data in))) + ((eq op 'TYI) + (if (and (not SI:QUERY-IO-NEW-LISP) bufl) + (progn (pop bufl data) + (setf (QUERY-IO-putbacklist self) bufl) + data) + (tyi data in))) + ((cond ((memq op '(TYO PRINT PRINC))) + ((memq op '(READ READLINE)) + (setq out in) + 'T)) + ;; Several trivial operations are just "passed down" directly to + ;; the appropriate part of the sfa. + (funcall op data out)) + ((caseq op + (CURSORPOS + (if (memq 'CURSORPOS (cdr (QUERY-IO-omode self))) + (si:spread-cursorpos data out) + ;; Just do nothing now if output side can't do CURSORPOS + )) + (TYIPEEK (if (and (not SI:QUERY-IO-NEW-LISP) bufl) + (car bufl) + (tyipeek data in -1))) + (OPEN (open in data) (open out data)) + (CLOSE (close in) (close out)) + (RUBOUT (if (memq 'RUBOUT (cdr (QUERY-IO-omode self))) + (rubout data out))) + (FRESH-LINE (SI:FRESH-LINIFY out)) + ((CHARPOS LINEL PAGEL PAGENUM FILEPOS + CLEAR-OUTPUT FORCE-OUTPUT) + ;; Notice how these funtions only pay attention to the output side + ;; of the bi-directional sfa. Also, The latter 2 better have had + ;; the third sfa argument ("data") sent as (). + (lexpr-funcall op out data)) + (LISTEN + (+ (cond ((and (not SI:QUERY-IO-NEW-LISP) bufl) + (length bufl)) + (0)) + (listen in))) + (CLEAR-INPUT + (if (and (not SI:QUERY-IO-NEW-LISP) bufl) + (setf (QUERY-IO-putbacklist self) () )) + (CLEAR-INPUT in)) + ((TTY TTYSCAN TTYINT TTYTYPE TTYSIZE OSPEED TERPRI LINMOD) + ;; Wow, look at all these [S]STATUS options! + ;; Remember, 'data' = () means STATUS, otherwise a list of args + ;; for SSTATUS to use. + (let (sstatusp operation-list) + (cond ((eq op 'TTYINT) + (desetq (operation-list . sstatusp) data) + (let (((char-no . fun?) operation-list) + quotifyp) + (if fun? (setq fun? `(',(car fun?)) quotifyp 'T)) + (if (not (numberp char-no)) + (setq char-no `',char-no quotifyp 'T)) + (if quotifyp (setq operation-list `(,char-no . ,fun?))))) + ('T (cond ((eq op 'TERPRI) (setq in out)) + ((not (memq op '(TTY TTYSCAN LINMOD))) + (if data + ;; Can't SSTATUS on TTYTYPE, TTYSIZE, OSPEED + (+internal-lossage 'SSTATUS + 'QUERY-IO-HANDLER + data)) + (setq in out))) + (setq operation-list data + sstatusp data))) + ;; Note that "in" and the items in the list "data" should be + ;; evaluative constants by now -- probably fixnums, or T or (). + (setq operation-list `(,op ,@operation-list ,in)) + (if sstatusp + (apply #'SSTATUS operation-list) + (apply #'STATUS operation-list)))) + (FILEMODE + ;;(status FILEMODE ...) sends () as "data", so we get the file mode + ;; of the "output" side of the SFA. + ;;If user does (SFA-CALL 'FILEMODE 'IN), he gets input mode, + ;; and (SFA-CALL 'FILEMODE 'OUT) likewise gets the output mode. + (cond ((memq data '(() OUT)) (QUERY-IO-omode self)) + ((eq data 'IN) (QUERY-IO-imode self)) + ('T (+internal-lossage 'FILEMODE 'QUERY-IO-HANDLER data)))) + ;(TTYCONS ...) ;Is a system slot in the SFA, the "XCONS" slot and thus + ; this status call does not send a message. + (+INTERNAL-TTYSCAN-SUBR + ;; Well, can you imagine (funcall (status ttyscan ) ...) + ;; so just "pass it down". + (+INTERNAL-TTYSCAN-SUBR in (car data) (cadr data))) + (WHICH-OPERATIONS + ;; Notice that (SFA-CALL 'WHICH-OPERATIONS ) + ;; will store into the WHICH-OPERATIONS slot + (if data (setf (QUERY-IO-whichops self) data)) + (if (null (QUERY-IO-whichops self)) + (setf (QUERY-IO-whichops self) + `(,@SI:QUERY-IO-EXTRA-OPTIONS + TYI UNTYI TYIPEEK TYO READ READLINE PRINT PRINC + OPEN CLOSE LISTEN CHARPOS LINEL PAGEL PAGENUM + TTY TTYSCAN TTYTYPE TTYSIZE TTYINT OSPEED LINMOD + FRESH-LINE CLEAR-OUTPUT FORCE-OUTPUT CLEAR-INPUT + FILEMODE WHICH-OPERATIONS))) + (QUERY-IO-whichops self)) + (T (sfa-unclaimed-message self op data)))))) + + +(defvar QUERY-IO 'T + "Where to ask questions from. Bidirectional. SFA-form is unaffected by ^W.") + +(and (eq QUERY-IO 'T) + (status feature SFA) + (setq QUERY-IO (cons-a-QUERY-IO))) + + + diff --git a/src/lspsrc/sendi.107 b/src/lspsrc/sendi.107 new file mode 100755 index 00000000..70568994 --- /dev/null +++ b/src/lspsrc/sendi.107 @@ -0,0 +1,297 @@ +; -*- MIDAS -*- +TITLE SENDI -- Standard Send Interpreter +.INSRT SYS:.FASL DEFS +.FASL + +SVERPRT SENDI,107 + +.INSRT LSPSRC;EXTMDF > + +.SXEVAL + (OR (STATUS STATUS SENDI) + (ERROR (QUOTE EXTEND/s/ /c/a/n/'/t/ /p/o/s/s/i/b/l/y/ /w/o/r/k/ /i/n/ /a/n/c/i/e/n/t/ LISP/s!))) + + + +;; (SI:MAP-OVER-CLASSES FUNCTION CLASS) +.entry SI:MAP-OVER-CLASSES SUBR 003 + movei r,[%mapcls tt,(c)] + movei f,(CALL 2,) ;2 args + jrst imapit + +; (SI:MAP-OVER-METHODS FUNCTION CLASS) +.entry SI:MAP-OVER-METHODS SUBR 003 + movei r,[%mapmth tt,(c)] + movei f,(CALL 3,) ;3 args +imapit: push fxp,flp ;Save the state of the stacks for + push fxp,p ;quick return + hrli a,(f) ;prepare to XCT-call the function + push fxp,a ;put on FXP so can be snapped. + push p,a + push p,b + move a,b ;let's check the second arg +mclp: pushj p,classp ;is this a class? + jumpe a,mclper + pop p,c ;Recover the class, now in C + pop p,a ;Get our function to balance the stack + setz a, ;SI:MAP-OVER-CLASSES expects () in A + xct (r) ;Get the map-method/class method + jumpe tt,mclper + pushj p,(tt) ;call it + pop fxp,a ;restore the state + pop fxp,p ;of our various PDL's + pop fxp,flp +false: setz a, ;Return () +cpopj: popj p, + + +mclper: push p,[mclp] +mclpr0: move a,(p) ;recover the non-class + WTA [NOT A CLASS OR, MAP-METHOD/CLASS IS MISSING!] + movem a,(p) + popj p, + + +.entry SI:STANDARD-MAP-OVER-METHODS MAP-METHODS 003 + %methd ar1,(c) ;Get methods + jumpe ar1,irecur ;If null, don't. Look at superiors instead + push p,c +mmsear: move a,(p) ;First arg is the class method is in + %mname b,(ar1) ;Get the method symbol + %mfsym c,(ar1) ;Get the method function + push p,ar1 ;save our state + xct (fxp) ;Invoke the user's function + jumpn a,mmret ;if non-nil return, go return result + pop p,ar1 ;recover state + %mnext ar1,(ar1) ;Get the next one + jumpn ar1,mmsear ;loop until end + pop p,c ;recover class being hacked. + movei r,[%mapmth tt,(c)] ;Pass in how to get recursion + jrst irecur + +.entry SI:STANDARD-MAP-OVER-CLASSES MAP-CLASSES 000 + move b,a ;Second arg: Previous class, or () + movei a,(c) ;First arg: Class + push p,c ;Don't forget what class we are + xct (fxp) ;Invoke the user's function + jumpn a,mmret ;If non-null, time to return. + pop p,c ;Recover class + movei a,(c) ;In super-classes, tell this is inferior of + ;Interest. + movei r,[%mapcls tt,(c)] ;How to get next level's routine. + +irecur: %super ar1,(c) ;Get list of superiors + jumpe ar1,cpopj ;no such luck +ircur0: hlrz c,(ar1) ;look at first + xct (r) ;Get in TT the frob to call + push p,ar1 ;Save our state + push flp,r ;Can't use FXP, has P on it. + skipe tt + pushj p,(tt) ;Call it + pop flp,r + pop p,ar1 + hrrz ar1,(ar1) ;He failed, look at next + jumpn ar1,ircur0 ;loop until end + popj p, ;Return our failure + +mmret: pop fxp,t ;flush the instruction + pop fxp,p ;restore the stack + pop fxp,flp ;Restore FLP + popj p, ;and return + +.entry SEND-AS LSUBR 004777 + movei r,(p) + addi r,(t) ;Get address of return address + movei c,cpopj + aos r ;Skip over this return address for now + exch c,(r) ;1st arg becomes CPOPJ, pick up class + hrrz a,1(r) ;Get object for sending + hrrz b,2(r) ;Get method name + aoja t,sndit ;one less argument + + +.entry SEND LSUBR 003777 +send: movei r,(p) + addi r,(t) ;Get address of return address + hrrz a,1(r) ;Get object for sending + movem a,1(r) ;Clear its left half! --RLB + hrrz b,2(r) ;Get method name + jsp d,getcls ;get the class +sndit: push fxp,p ;remember size of stack so can restore + %sendi tt,(c) ;get the send interpreter + skipe tt + pushj p,(tt) ;invoke it + ;Send interpreters return on failure + pop fxp,p ;balance the PDL's + jcall 16,.function SI:LOST-MESSAGE-HANDLER + + +.ENTRY TYPE-OF SUBR 002 ;Better than TYPEP! + jsp d,getcls + %typep a,(c) ;Fetch the type from whatever class + popj p, + + +.entry CLASSP SUBR 002 +classp: movei tt,(a) + lsh tt,-seglog + skipge tt,st(tt) ;Must be some kind of HUNK + tlnn tt,hnk + jrst false + %marker tt,(a) ;With the marker in the CAR + came tt,.special SI:CLASS-MARKER + jrst false + hrrz a,(a) ;Get the "class pointer" + movei tt,(a) ;The class pointer must also + lsh tt,-seglog ;pass the same two tests + skipge tt,st(tt) + tlnn tt,hnk + jrst false + %marker tt,(a) ;Get the marker + came tt,.special SI:CLASS-MARKER + jrst false +truth: movei a,.atom T ;Passed all the tests, it's a class! + popj p, + +.entry CLASS-OF SUBR 002 + jsp d,getcls + move a,c ;GETCLS returns in C for SI:SEND + popj p, + +getcls: jumpe a,nilcls ;+ETERNAL-SPECIAL-CASE-CROCK + movei tt,(a) ;copy + lsh tt,-seglog ;get index into segment table + hrrz tt,st(tt) ;get the type + subi tt,.atom LIST ;get the type code number + xct clstab(tt) + jrst (d) +nilcls: move c,.special NULL-CLASS + jrst (d) + +clstab: + move c,.special PAIR-CLASS + IRPS x,,[FIXNUM FLONUM BIGNUM SYMBOL] + move c,.special x!-CLASS +TERMIN +REPEAT hnklog, jrst snhnk + move c,.special RANDOM-CLASS + jrst snary + +snary: move c,.special ARRAY-CLASS ;An array; check for special cases + move tt,ASAR(a) ;Get the ASAR bitss + tlne tt,as.sfa ;Is it an SFA? + move c,.special SFA-CLASS + tlne tt,as.fil ;Is it a file? + move c,.special FILE-CLASS + tlne tt,as.job ;Heh heh, is it a JOB? + move c,.special JOB-CLASS + jrst (d) + +snhnk: hrrz tt,(a) ;get the class of this object + lsh tt,-seglog ;check it out + move tt,st(tt) + tlnn tt,HNK ;Is this a hunk? + jrst symul ; No, hack as random system datum + %class c,(a) + %marker tt,(c) ;Get the marker of this class + came tt,.special SI:CLASS-MARKER +symul: move c,.special HUNK-CLASS + jrst (d) + +;; SEND interpreters expect: +;; In A, the object +;; In B, the method name +;; In C, the class from which the SEND interpreter was extracted +;; In R, the address of the return address on the stack. +;; On FXP, the saved P to restore before calling method, to flush the +;; saved state from the SEND interpreters +;; An arbitrary amount of cruft on the stack beyond point saved on FXP +;; For the sake of trampolines, they should leave the method bucket in +;; AR2A + +.entry SI:DEFAULT-SENDI SENDI 000 ;not to be called, just need property + %methd ar2a,(c) ;get the dispatch list + jumpe ar2a,sndup ;if NIL, try superiors +mthlp: %mname ar1,(ar2a) ;get the method name + cain ar1,(b) ;is it this one? (symbol in right half) + jrst sndgo ; yes, do it up! + %mnext ar2a(ar2a) ;next method + jumpn ar2a,mthlp ;(unless end) + +sndup: %super ar1,(c) ;get superiors + jumpe ar1,sndfail ;failed if none +suplp: hlrz c,(ar1) ;get the class to hack + push p,ar1 ;save our state + %sendi tt,(c) ;get the send interpreter + skipe tt + pushj p,(tt) ;invoke it + pop p,ar1 ;it failed, recover our state + hrrz ar1,(ar1) ;throw that class away + jumpn ar1,suplp ;try next +sndfail: + popj p, ;foo, we failed too. + +sndgo: pop fxp,p ;restore our stack to initial state + %msubr tt,(ar2a) ;get the LSUBR part of the method + jumpn tt,(tt) ;and invoke it if found + ;Not compiled (or undefined...) + %mfsym tt,(ar2a) ;Get the symbol or lambda or whatever + jcall 16,(tt) ;(closure!?) + +.entry SI:SFA-SENDI SENDI 000 + pop fxp,p ;Flush all the cruft + move ar1,a ;Save the SFA + setzb a,b ;Start with NIL + move tt,t ;T is clobbered by JSP T,%CONS + aos tt ;We don't want the SFA consed in +sfasnl: pop p,a + jsp t,%cons + aojl tt,sfasnl ;Terminates when we cons the message + ;onto the list + move c,a ;Get the result + movei b,.atom :SEND + pop p,a ;Get the SFA + jcall 3,.function SFA-CALL + +;; CALLI frobs are called with the stack in IAPPLY format + +.entry SI:DEFAULT-CALLI CALLI 000 ;not to be called, just need property + movei tt,(p) + addi tt,1(t) ;get address of first arg + hrli tt,-1(t) ;Make it into an AOBJN ptr to args + push p,NIL ;Make room for additional arg + movei b,.atom CALL ;First arg comes out of the blue + hrrzs (tt) ;Flush left-half +dcloop: exch b,(tt) ;swap! previous goes in this slot, save this + aobjn tt,dcloop ;for next time around + subi t,2 ;count 2 additional arguments, self and CALL + jrst send ;go send the message + +.entry SI:CALLI-TRANSFER CALLI 000 + move tt,t ;copy number of args + addi tt,(p) ;get loc of function + hrrz a,(tt) ;get "function" + hrrz a,(a) ;get class + %calli tt,(a) ;get CALLI interpreter from the class + jrst (tt) ;Invoke it + +.entry EXTENDP SUBR 002 +.entry SI:EXTENDP SUBR 002 + movei tt,(a) ;copy + lsh tt,-seglog + move tt,st(tt) + tlnn tt,HNK + jrst false + hrrz a,(a) ;CDR + movei tt,(a) + lsh tt,-seglog + move tt,st(tt) + tlnn tt,hnk + jrst false + %marker b,(a) ;Get the marker + movei a,.atom T + came b,.special SI:CLASS-MARKER + setz a, + popj p, + +FASEND diff --git a/src/lspsrc/straux.74 b/src/lspsrc/straux.74 new file mode 100755 index 00000000..5d149153 --- /dev/null +++ b/src/lspsrc/straux.74 @@ -0,0 +1,1260 @@ +;;; ************************************************************** +TITLE ***** MACLISP ****** STRing AUXillary functions ************** +;;; ******************** Fast-string Support ********************* +;;; ************************************************************** +;;; ** (C) COPYRIGHT 1981 MASSACHUSETTS INSTITUTE OF TECHNOLOGY ** +;;; ****** THIS IS A READ-ONLY FILE! (ALL WRITES RESERVED) ******* +;;; ************************************************************** + +.FASL +.INSRT SYS:FASDFS + +.SXEVAL (DEFPROP STRAUX 74 VERSION) + +; --------- +;A "STRING" is a 4-hunk, with | 1 | 0 | +; indices as indicated in the --------- +; diagram. | 3 | 2 | +; --------- +; (cxr 0 s) ;ptr to class object for STRINGs +; (cxr 1 s) ;"**SELF-EVAL**" +; (cxr 2 s) ;word-index in STR:ARRAY of first word +; (cxr 3 s) ;length of string, in characters + +STWIWO==1 ;STRING-WORD-INDEX, WORD-OFFSET - A RH QUANTITIY +STLNWO==1 ;STRING-LENGTH, WORD-OFFSET - A LH QUANTITIY +STSEWO==0 ;STRING "SELF-EVAL" MARKER, WORD-OFFSET + +CHNVWO==1 ;Character's numerical value word - A RH QUANTITIY + +DEFINE STRWDNO AC,IX + HRRZ AC,STWIWO(IX) + SKIPGE AC,(AC) +TERMIN + +DEFINE STRLEN AC,IX + HLRZ AC,STLNWO(IX) + MOVE AC,(AC) +TERMIN + +;Check for new-data-type - STRING or CHARACTER + +DEFINE CHKSTR ERRH + PUSHJ P,SCHKSTR + JUMPE T,ERRH +TERMIN +DEFINE CHKCHR ERRH + PUSHJ P,SCHKCHR + JUMPE T,ERRH +TERMIN + +SCHKSTR: PUSH P,A + PUSH P,B + PUSH P,C + PUSH FXP,F + CALL 1,.FUNCT STRINGP +XSCHKSTR: POP FXP,F + MOVE T,A + POP P,C + POP P,B + POP P,A + POPJ P, +SCHKCHR: PUSH P,A + PUSH P,B + PUSH P,C + PUSH FXP,F + CALL 1,.FUNCT CHARACTERP + JRST XSCHKSTR + + + + +;Check for STRING in A, valid index in B (fall thru if index is bad) +DEFINE ST2ACK ERRH,OKADDR + CHKSTR ERRH + STRLEN R,A ;WILL LEAVE STRING-LENGTH IN R + JSP T,FXNV2 ;CERTIFY SECOND ARG AS FIXNUM + CAIGE D,(R) ;REQUESTED INDEX MUST BE LESS THAN MAX INDEX + JUMPGE D,OKADDR +TERMIN + +;;; same as ST2ACK, except string index is allowed to be equal to the length +;;; of the string; if there is an error, it can occur only when CNT arg +;;; is *not* zero. +DEFINE ST2%ACK ERRH,OKADDR + CHKSTR ERRH + STRLEN R,A ;WILL LEAVE STRING-LENGTH IN R + JSP T,FXNV2 ;CERTIFY SECOND ARG AS FIXNUM + CAIG D,(R) ;REQUESTED INDEX MUST BE LESS THAN MAX INDEX + JUMPGE D,OKADDR +TERMIN + + + +;LaST-BYTe-ify - take the word/byte specifier for a string place, +; and a count, given as 5*(A)+(B), and convert it to a word/byte +; specifier for the "last" byte of the indicated substring. +;The register, dummy arg "W1", holds the word addr, and W1+1 must +; hold the byte address (as a byte number within word). + +DEFINE LSTBYTIFY W1\TG1,TG2 + ADD W1,A + ADD W1+1,B + SOJGE W1+1,TG1 + SOS W1 + MOVEI W1+1,4 + JRST TG2 +TG1: CAIGE W1+1,5 + JRST TG2 + AOS W1 + SUBI W1+1,5 + JRST TG1 +TG2: +TERMIN + + + +;;; Some PDL offsets defined for STRING-POSQ and STRING-REPLACE + +DEFINE MAKE1 NM,PDL,OFF +DEFINE NM +OFF(PDL) +TERMIN +TERMIN + +IRP NM,,[CNTP,CNT,I2,S2,XCH] +MAKE1 NM,P,\-.IRPCNT +TERMIN +IRP NM,,[INHBFL,N,BY2,WD2,NI2,NCH,NUMCFL,BKWP,OPERATION] +MAKE1 NM,FXP,\-.IRPCNT +TERMIN +;-4 allows for CNTP,CNT,I2,S2 to be above these goodies on PDL +IRP NM,,[I1,S1] +MAKE1 NM,P,\-4-.IRPCNT +TERMIN +;-4 allows for INHBFL,N,BY2,WD2, to be above these goodies on PDL +IRP NM,,[BY1,WD1] +MAKE1 NM,FXP,\-4-.IRPCNT +TERMIN + + + +SUBTTL ERROR MSGS and STR/:OWORD-N, STR/:OSET-WORD-N + +IRP A,,[FILL,POSQ,SKIPQ,SCHAR,SCHAR,SNCHAR,SSET,SNSET] +4T.!A==.IRPCNT +TERMIN + +;;; THE "OPERATION" IS AN INTEGER ENCODING THE OPERATION TYPE AS FOLLOWS: +;;; 0 - FILL (and FILL-N) 4T.FILL +;;; 1 - POSQ (and POSQ-N) 4T.POSQ +;;; 2 - SKIPQ (and SKIPQ-N) 4T.SKIPQ +;;; 3 - +;;; 4 - SEARCH-CHAR 4T.SCHAR ; +;;; 5 - SEARCH-NOT-CHAR 4T.SNCHAR +;;; 6 - SEARCH-SET 4T.SSET +;;; 7 - SEARCH-NOT-SET 4T.SNSET + +NILBKWP=1 +LISPMBKWP=2 +;;;The "BKWP", if not null, is either 1, meaning 'backwardsp' in the NIL +;;; style (start index is actual highest index); or 2, meaning LISPM +;;; style (start index is one greater than highest tested index). + + +CZERO: .ATOM #0 + +WNAERE: LERR [SIXBIT \ WRONG NUMBER OF ARGUMENTS FOR A STRING OPERATION!\] +NACER: SIXBIT \ -- "CHARACTER" REQUIRED FOR STRING OPERATION!\ +NACCVER: SIXBIT \ -- NUMERICAL (ASCII) CHARACTER VALUE REQUIRED FOR STRING OPERATION!\ +BISER: SIXBIT \ -- BAD INDEX FOR STRING OPERATION!\ +SR2ERM: SIXBIT \ -- INDEX OUT OF RANGE FOR STRING-REPLACE!\ +BISPSK: SIXBIT \BUG IN STRING-POSQ/SKIPQ!\ +NASTER: SIXBIT \ -- STRING REQUIRED FOR STRING OPERATION!\ + + +BISERE: EXCH A,B + %WTA BISER + EXCH A,B + POPJ FLP + + +.ENTRY STR/:OWORD-N SUBR 000003 + PUSH P,CFIX1 + STRWDNO TT,A + JRST $ISW1 + ;;TT NOW HAS WORD-INDEX-IN-ARRAY OF STRING BASE + ADD TT,(B) ;WORD-INDEX-IN-STRING OF REQUESTED WORD + MOVE TT,@.ARRAY STR/:ARRAY ;GETS TTSAR?? + POPJ P, +$ISW1: ADD TT,(B) ;WORD-INDEX-IN-STRING OF REQUESTED WORD + MOVE TT,(TT) + POPJ P, + +.ENTRY STR/:OSET-WORD-N SUBR 000003 + MOVE R,(C) ;GET NEW WORD + STRWDNO TT,A + JRST $ISSW1 + ;;TT NOW HAS WORD-INDEX-IN-ARRAY OF STRING BASE + ADD TT,(B) ;WORD-INDEX-IN-STRING OF REQUESTED WORD + MOVEM R,@.ARRAY STR/:ARRAY + POPJ P, +$ISSW1: ADD TT,(B) ;WORD-INDEX-IN-STRING OF REQUESTED WORD + MOVEM R,(TT) + POPJ P, + + + +SUBTTL RPLACHAR-N, CHAR-N + +;;; CHAR-N and RPLACHAR-N -- each takes about 17 JJ's (JonlJiffies) of time. +;;; on minimun path (non-*rset mode) + +.ENTRY RPLACHAR-N SUBR 000004 +$RPLCN: SKIPE .SPECIAL *RSET + JRST RPCH1K +RPCH1B: JCALL 3,.FUNCTION +INTERNAL-RPLACHAR-N + + +;ERROR CODE FOR RPLACHAR +RPCH1K: ST2ACK RPCHERR,RPCH1C ;Falls thru on index error + PUSHJ FLP,BISERE + JRST $RPLCN +RPCHERR: %WTA NASTER + JRST $RPLCN +RPCH1C: JSP T,FXNV3 ;THIRD ARG MUST BE A FIXNUM + SKIPL F,R + CAILE F,177 + JRST RPCCERR + JRST RPCH1B +RPCCERR: EXCH A,C + %WTA NACCVER + EXCH A,C + JRST $RPLCN + + + +.ENTRY STR/:ORPLACHAR-N SUBR 000004 +;;FOLLOWING CODE WILL FILL THE PLACE OF +INTERNAL-CHARN-N IN OLDER LISPS + MOVE D,(B) ;BASIC RPLACHAR'ER! + MOVE F,(C) + IDIVI D,5 + STRWDNO TT,A ;WORD-INDEX-IN-ARRAY OF STRING BASE + JRST RPCH1S + ADDI TT,(D) + DPB F,BPAR(R) + POPJ P, +RPCH1S: ADDI D,(TT) + DPB F,BPARS(R) + POPJ P, + + +;Table of byte-ptrs, into "array" by indirecting thru special array cell +BPAR: REPEAT 5, @<<35-7*.RPCNT>_36>+07_30 .ARRAY STR/:ARRAY + +;Table of byte-ptrs for absolute address, index'd by D +BPARS: REPEAT 5, <<35-7*.RPCNT>_36>+07_30 (D) + +;Table of just the LH of byte-ptrs, but origined just before the word +PPSSTB: REPEAT 6,<<44-7*.RPCNT>_36>+07_30 + + + + +.ENTRY CHAR-N SUBR 000003 +$CHARN: PUSH P,CFIX1 +CHAR1: SKIPE .SPECIAL *RSET + JRST CHAR1C +CHAR1B: NJCALL 2,.FUNCTION +INTERNAL-CHAR-N + +;ERROR CODE FOR CHAR +CHAR1C: ST2ACK CHHERR,CHAR1B ;Falls thru on index error + PUSHJ FLP,BISERE + JRST CHAR1 +CHHERR: %WTA NASTER + JRST CHAR1 + + + +;;FOLLOWING CODE WILL FILL THE PLACE OF +INTERNAL-CHARN-N IN OLDER LISPS +.ENTRY STR/:OCHAR-N SUBR 000003 + PUSH P,CFIX1 + MOVE D,(B) ;BASIC CHARACTER GET'ER + IDIVI D,5 + STRWDNO TT,A ;WORD-INDEX-IN-ARRAY OF STRING BASE + JRST CHAR1S + ADDI TT,(D) ;WORD-INDEX-IN-STRING OF REQUESTED CHAR + LDB TT,BPAR(R) ;IMPURE STRINGS HAVE WORD-INDEX INTO + POPJ P, ; STR/:STRING-ARRAY +CHAR1S: ADDI D,(TT) + LDB TT,BPARS(R) ;PURE STRINGS HAVE ABSOLUTE ADDRESS + POPJ P, ;REMEBER, INDEXING OFF "D" + + + +;; Fixup for LISPs older than version 2052 + +.SXEVAL (MAPC (FUNCTION + (LAMBDA (X Y) + (OR (SYSP (GET X (QUOTE SUBR))) + (PUTPROP X (GET Y (QUOTE SUBR)) (QUOTE SUBR))))) + (QUOTE (+INTERNAL-CHAR-N + +INTERNAL-RPLACHAR-N + +INTERNAL-STRING-WORD-N + +INTERNAL-SET-STRING-WORD-N)) + (QUOTE (STR/:OCHAR-N + STR/:ORPLACHAR-N + STR/:OWORD-N + STR/:OSET-WORD-N))) + + + + +SUBTTL CHAR-EQUAL, CHAR-LESSP, CHAR-DOWNCASE, CHAR-UPCASE, + +.ENTRY CHAR-EQUAL SUBR 000003 + TDZA R,R +.ENTRY CHAR-LESSP SUBR 000003 + MOVEI R,1 ;R HOLDS "EQUAL"P + SKIPE .SPECIAL *RSET + JRST CHEQ1 + MOVE TT,(A) + MOVE D,(B) +CHEQ0: CAIL TT,"a + CAILE TT,"z + JRST .+2 + SUBI TT,"a-"A + CAIL D,"a + CAILE D,"z + JRST .+2 + SUBI D,"a-"A + XCT CHEQTB(R) + TDZA A,A + MOVEI A,.ATOM T + POPJ P, + +CHEQ1: JSP T,FXNV1 + JSP T,FXNV2 + JRST CHEQ0 + +CHEQTB: CAME TT,D + CAML TT,D + + +.ENTRY CHAR-DOWNCASE SUBR 000002 + PUSH P,CFIX1 + SKIPN .SPECIAL *RSET + SKIPA TT,(A) + JSP T,FXNV1 + CAIL TT,"A + CAILE TT,"Z + JRST .+2 + ADDI TT,"a-"A + POPJ P, + +.ENTRY CHAR-UPCASE SUBR 000002 + PUSH P,CFIX1 + SKIPN .SPECIAL *RSET + SKIPA TT,(A) + JSP T,FXNV1 + CAIL TT,"a + CAILE TT,"z + JRST .+2 + SUBI TT,"a-"A + POPJ P, + + +SUBTTL STR/:CLEAR-WORDS, STR/:GRAB-PURSEG + +.ENTRY STR/:CLEAR-WORDS SUBR 000003 + SKIPN D,(B) + JRST CPOPJ + LOCKI + HRRZ R,.ARRAY STR/:ARRAY ;GETS TTSAR?? + STRWDNO F,A + SKIPA R,F ;"PURE" STRING ALREADY HAS ADDRESS + ADD R,F ;ADDR OF FIRST WORD TO CLEAR + SETZM (R) + SOJE D,UNLKX + ADDI D,(R) + HRLI R,1(R) + MOVSS R + BLT R,(D) +UNLKX: UNLKPOPJ + +;; comment +.ENTRY STR/:COMPARE-WORDS SUBR 000003 + LOCKI + STRLEN TT,A + STRLEN D,B + CAME TT,D + JRST CWLOSE + JUMPE D,CWWIN + SOS D ;CALCULATE THE NEGATIVE OF + IDIVI D,5 ; NUMBER OF WORDS TO COMPARE + MOVNI D,1(D) + HRRZ R,.ARRAY STR/:ARRAY ;GETS TTSAR?? + STRWDNO F,A + SKIPA ;"PURE" STRING ALREADY HAS ADDRESS + ADD F,R ;ADDR OF FIRST WORD OF FIRST STRING + STRWDNO TT,B + SKIPA R,TT ;"PURE" STRING ALREADY HAS ADDRESS + ADD R,TT ;ADDR OF FIRST WORD OF SECOND STRING + HRL F,D ;MAKE AOBJN PTR + MOVE TT,(F) + CAME TT,(R) + JRST CWLOSE + AOS R + AOBJN F,.-4 +CWWIN: SKIPA A,.SPECIAL */:TRUTH +CWLOSE: MOVEI A,0 + JRST UNLKX + + + +.ENTRY STR/:GRAB-PURSEG SUBR 000001 + PUSH P,CFIX1 + PUSHJ P,GRBPSG + LSH T,SEGLOG + MOVE TT,T + POPJ P, + + +SUBTTL STRING-SKIPQ, STRING-POSQ, and variants + +;;; STRING-POSQ &optional ( 0) ( 0 ) + +;;; STRING-POSQ, and variants for "Backwards" searching, and for "numeric" +;;; argument (instead of "CHARACTER"). +;;; The entry/exit overhead is (in minimun, non-*rset mode path) about 75 JJ's +;;; (JonlJiffies), with about another 75 JJ's for loop set-up time, and +;;; then about 2 JJ's for each character passed over. + + +.ENTRY STRING-SKIPQ LSUBR 003005 + TDZA F,F +.ENTRY STRING-BSKIPQ LSUBR 003005 + MOVEI F,NILBKWP + SETZ R, + JRST SSK0 +.ENTRY STRING-SKIPQ-N LSUBR 003005 + TDZA F,F +.ENTRY STRING-BSKIPQ-N LSUBR 003005 + MOVEI F,NILBKWP ;F - "BACKWARDSP" + MOVEI R,.ATOM T ;R - "NUMERIC-CHARACTERP" +SSK0: MOVEI D,4T.SKIPQ ;D - "OPERATION" + JRST SPQSK0 + + +.ENTRY STRING-POSQ LSUBR 003005 + TDZA F,F +.ENTRY STRING-BPOSQ LSUBR 003005 + MOVEI F,NILBKWP + SETZ R, + JRST SPQ0 +.ENTRY STRING-POSQ-N LSUBR 003005 + TDZA F,F +.ENTRY STRING-BPOSQ-N LSUBR 003005 + MOVEI F,NILBKWP + MOVEI R,.ATOM T +SPQ0: MOVEI D,4T.POSQ +SPQSK0: PUSH FXP,D ;"OPERATION" - SKIPQ, POSQ, FILL + PUSH FXP,F ;"BACKWARDSP" FLAG + PUSH FXP,R ;"NUMCFL" + JSP F,SPQFL% ;SET UP STACK-FRAME, PUSH "INHIBIT", + SKIPN N ; AND GET STRING PTR IN A + JRST SPQLUZ + JSP T,SPQFL. ;CALCULATE WORD- AND BYTE- INDICES + SKIPE BKWP + JRST [ CAIN R,4 + JRST SPQ6C + JRST SPQ6L ] + JUMPE R,SPQ4C + +;;;FALLS THRU + +;;;FALLS THRU + + ; AT THIS POINT, IN THE "CACHE" IS: D - WD2, R - BY2, A - N + +;Word-align the string-index, in left-most byte of word +SPQ4L: MOVE 5,D ;STARTING AT INDEX NOT "WORD ALIGNED" + HLL 5,PPSSTB(R) + SKIPG C,OPERATION ;SKIPQ or POSQ? + LERR BISPSK + MOVE F,SP4TB-4T.POSQ(C) ;WILL BE EITHER CAME B,C OR CAMN + MOVE C,NCH ;C NOW HAS THE CHAR (IN NUMERIC FORM) + SUBI R,5 + MOVM TT,R +SPQ4A: ILDB B,5 ;LOOP, 1 CHAR AT A TIME, + XCT F ; UNTIL "WORD-ALIGNED" + JRST SPQ4BDONE + SOJLE A,SPQLUZ ;DECREMENTS "N" + AOJL R,SPQ4A + ADDM TT,NI2 ;UPDATE "START-INDEX" BY NO. OF CHARS + AOS D,WD2 ; FROBBLED, AND GO TO NEXT WORD + SETZB R,BY2 +SPQ4C: IDIVI A,5 + MOVEM B,N + + ;AT THIS POINT, THE INDEX IS NOW "LEFT-ALIGNED" IN A WORD + ; AND WE NEED TO DO "N" MORE CHARACTERS, WHICH IS THE SAME AS + ; N/5 WORDS AND N\5 CHARS IN THE WORD PRECEEDING THAT + + ; AT THIS POINT, IN THE "CACHE" IS: D - WD2, B - N + +SPQ4D: JUMPE A,SPQ4E1 + MOVE T,[004020100402] + MUL T,NCH ;5 COPIES OF THE BYTE IN QUESTION + CAIE T,0 + TLO TT,400000 + MOVE F,[000017700000] ;MIDDLE-BYTE MASK + MOVEI R,5 ;INCREMENT TO NI2 EACH TIME THRU LOOP + SKIPG T,OPERATION + LERR BISPSK + CAIE T,4T.POSQ + JRST SSK4E +SPQ4E: MOVE T,(D) ;The "group" form of POSQ + XOR T,TT + TLNN T,774000 + JRST SPQDONE + TLNN T,003760 + JRST [ MOVEI TT,1 + JRST SPQ4DONE ] + TDNN T,F + JRST [ MOVEI TT,2 + JRST SPQ4DONE ] + TRNN T,077400 + JRST [ MOVEI TT,3 + JRST SPQ4DONE ] + TRNN T,000376 + JRST [ MOVEI TT,4 + JRST SPQ4DONE ] + AOJ D, + ADDM R,NI2 + SOJN A,SPQ4E + MOVEM D,WD2 +SPQ4E1: SETZB R,BY2 + SKIPN A,N ;Restore cache - see SPQ4L + JRST SPQLUZ + JRST SPQ4L + +SP4TB: CAMN B,C ;CONTINUE TEST FOR POSQ + CAME B,C ;CONTINUE TEST FOR SKIPQ + +SSK4E: MOVE T,(D) ;The "group" form of SKIPQ + XOR T,TT + TLNE T,774000 + JRST SPQDONE + TLNE T,003760 + JRST [ MOVEI TT,1 + JRST SPQ4DONE ] + TDNE T,F + JRST [ MOVEI TT,2 + JRST SPQ4DONE ] + TRNE T,077400 + JRST [ MOVEI TT,3 + JRST SPQ4DONE ] + TRNE T,000376 + JRST [ MOVEI TT,4 + JRST SPQ4DONE ] + AOJ D, + ADDM R,NI2 + SOJN A,SSK4E + MOVEM D,WD2 + JRST SPQ4E1 + + +SPQLUZ: MOVEI A,NIL + JRST SPQFL$ + +SPQDONE: TDZA TT,TT +SPQ4BDONE: ADD TT,R +SPQ4DONE: ADD TT,NI2 + JSP T,FIX1A +SPQFL$: SETZB 2,3 + SETZB 4,5 + UNLOCKI + SUB FXP,R70+NPQFXV-1 + SUB P,R70+5 ;4 ARGS AND "CNTP" + POPJ P, + + + + ;AT THIS POINT, IN THE "CACHE" IS: D - WD2, R - BY2, A - N + +;Word-align the string-index, in right-most byte of word +SPQ6L: MOVE 5,D + HLL 5,PPSSTB+1(R) + SKIPN C,OPERATION + LERR BISPSK + MOVE F,SP4TB-4T.POSQ(C) ;WILL BE EITHER CAME B,C OR CAMN + MOVE C,NCH ;C NOW HAS THE CHAR (IN NUMERIC FORM) + MOVE T,[0700_30] + MOVN TT,R ; R is 0-3, but not 4 +SPQ6A: LDB B,5 + XCT F + JRST SPQ4BDONE + SOJLE A,SPQLUZ ;DECREMENTS "N" + ADD 5,T ;DECREMENT BP + SKIPGE 5 + SUB 5,[430000,,1] + SOJGE R,SPQ6A + SOS TT + ADDM TT,NI2 + SOS D,WD2 + MOVEI R,4 + MOVEM R,BY2 +SPQ6C: IDIVI A,5 + MOVEM B,N + + ;AT THIS POINT, THE INDEX IS NOW "RIGHT-ALIGNED" IN A WORD + ; AND WE NEED TO DO "N" MORE CHARACTERS, WHICH IS THE SAME AS + ; N/5 WORDS AND N\5 CHARS IN THE WORD PRECEEDING THAT + + ; AT THIS POINT, IN THE "CACHE" IS: D - WD2, R - BY2, B - N + +SPQ6D: JUMPE A,SPQ6E1 + MOVE T,[004020100402] + MUL T,NCH ;5 COPIES OF THE BYTE IN QUESTION + CAIE T,0 + TLO TT,400000 + MOVE F,[000017700000] ;MIDDLE-BYTE MASK + MOVNI R,5 ;DECREMENT TO NI2 EACH TIME THRU LOOP + SKIPG T,OPERATION + LERR BISPSK + CAIE T,4T.POSQ + JRST SSK6E +SPQ6E: MOVE T,(D) + XOR T,TT + TRNN T,000376 + JRST SPQDONE + TRNN T,077400 + JRST [ MOVNI TT,1 + JRST SPQ4DONE ] + TDNN T,F + JRST [ MOVNI TT,2 + JRST SPQ4DONE ] + TLNN T,003760 + JRST [ MOVNI TT,3 + JRST SPQ4DONE ] + TLNN T,774000 + JRST [ MOVNI TT,4 + JRST SPQ4DONE ] + SOJ D, + ADDM R,NI2 + SOJN A,SPQ6E + MOVEM D,WD2 +SPQ6E1: MOVEI R,4 + MOVEM R,BY2 + SKIPN A,N ;Restore cache - see SPQ6L + JRST SPQLUZ + JRST SPQ6L + +SSK6E: MOVE T,(D) + XOR T,TT + TRNE T,000376 + JRST SPQDONE + TRNE T,077400 + JRST [ MOVNI TT,1 + JRST SPQ4DONE ] + TDNE T,F + JRST [ MOVNI TT,2 + JRST SPQ4DONE ] + TLNE T,003760 + JRST [ MOVNI TT,3 + JRST SPQ4DONE ] + TLNE T,774000 + JRST [ MOVNI TT,4 + JRST SPQ4DONE ] + SOJ D, + ADDM R,NI2 + SOJN A,SSK6E + MOVEM D,WD2 + JRST SPQ6E1 + + +SUBTTL Checking Routines for SKIPQ, POSQ, and FILL + +;Pushes things, does a LOCKI, and leaves string ptr in A +SPQFL%: ADDI T,4 + JUMPE T, [ PUSH P,[.ATOM T ] ;"CNTP" set to T + JRST SPQ1A0 ] + JUMPL T,WNAERE + SOJE T,SPQ1A1 ;only "CNT" not supplied + SOJG T,WNAERE + SKIPE -1(FXP) ;"BKWP", but others not yet pushed + HRROS -1(FXP) ; set up "I2P" in lh of "BKWP" + PUSH P,CZERO ;Make space for "I2" +SPQ1A1: PUSH P,CZERO ;Make space for "CNT" + PUSH P,R70 ;"CNTP" set to () +SPQ1A0: SKIPE -1(FXP) ;"BKWP", but others not yet pushed + JRST SPQ1A ;An 'OPERATION' of 0 means FILL + SKIPN -2(FXP) ;"OPERATION", but others not yet pushed + JRST [ MOVE T,S2 ;Must reverse first two args + EXCH T,XCH ; of a call to STRING-FILL + MOVEM T,S2 + JRST SPQ1A ] +SPQ1A: SKIPN .SPECIAL *RSET + JRST SPQ2 + MOVE A,XCH ;"NUMCFL", but notice that other things + SKIPE (FXP) ; are not yet pushed + JRST [ JSP T,FXNV1 + JUMPL TT,SPQCERR ;Certify 1st arg as FIXNUM for ASCII + CAILE TT,177 ; character value + JRST SPQCERR + JRST SPQ1E ] + MOVE TT,-2(FXP) ;"OPERATION", but others not yet pushed + CAIL TT,4T.SSET + JRST SPQ1E + CHKCHR SPQNCERR ;For non-"SET" operations, chk for char +SPQ1E: MOVE A,S2 + MOVE B,I2 + ST2%ACK SPQHERR,SPQ1B ;Leave string-length in R, fall thru on error +SPQIERR: PUSHJ FLP,BISERE + MOVEM B,I2 + SKIPE -1(FXP) ;"BKWP", but others not yet pushed + HRROS -1(FXP) ; set up "I2P" in lh of "BKWP" + JRST SPQ1A +SPQCER: %WTA NACCVER + SKIPA +SPQNCER: %WTA NACER + MOVEM A,XCH + JRST SPQ1A +SPQHER: %WTA NASTER + MOVEM A,S2 + JRST SPQ1A + + +SUBTTL Calculation Routines for SKIPQ, POSQ, and FILL + +;ST2%ACK macro has left numerical index in D, numerical string length in R. +SPQ1B: HRL T,-1(FXP) ;"BKWP", but others not yet pushed + TLNE T,LISPMBKWP + SOS D + SKIPN CNTP + JRST SPQ2 + MOVE A,CNT + JSP T,FXNV1 ;"CNT" ARG MUST BE FIXNUM + JUMPL TT,SPQNERR + SKIPE -1(FXP) ;"BKWP", but others not yet pushed + JRST [ SUB D,TT + AOJL D,SPQNERR + JRST SPQ2 ] + ADD D,TT + CAILE D,(R) + JRST SPQNERR +SPQ2: SKIPN (FXP) ;"NUMCFL", BUT OTHER THINGS NOT YET PUSHED + JRST [ MOVE T,XCH + MOVE TT,-2(FXP) ;"OPERATION", but others not yet pushed + CAIGE TT,4T.SSET ;If not 'SET' searching, then get char's + HRRZ T,CHNVWO(T) ; actual numerical value + JRST SPQ2B + ] + MOVE T,@XCH +SPQ2B: +SPQ2S==. + PUSH FXP,T ;NCH + PUSH FXP,R70 ;NI2 + PUSH FXP,(FXP) ;WD2 + PUSH FXP,R70 ;BY2 + PUSH FXP,@CNT ;N + PUSH FXP,INHIBIT ;INHIBIT - part of a LOCKI +NPQFXV==.-SPQ2S+3 ;ADD IN 3 FOR "OPERATION", "BKWP", AND "NUMCFL" + MOVE A,S2 + STRLEN TT,A ;STRING-LENGTH INTO TT +SPQ2C: MOVE T,@I2 ;DONE THIS WAY SO THAT CORRECTIBLE ERROR CAN + MOVEM T,NI2 ; RETURN TO HERE + SKIPE T,BKWP + JRST [ TLNN T,-1 + JRST [ TRNE T,LISPMBKWP + SOS NI2 + CAMGE TT,NI2 + JRST SPQ2E ;I2 was supplied. + MOVE TT,NI2 + AOJA TT,SPQ2A ] + TRNE T,LISPMBKWP + SUBI TT,1 + MOVEM TT,NI2 ;If I2 not supplied, set NI2 to max + AOJA TT,SPQ2A ; possible index, and prepare to set N + ] + SUB TT,NI2 + JUMPL TT,SPQ2E +SPQ2A: SKIPN CNTP + JRST [ MOVEM TT,N ;CALCULATE CNT FROM OTHER ARGS + JRST SPQ3 ] + CAMGE TT,N + JRST [ MOVE A,CNT + PUSHJ FLP,SPQCNR + JRST SPQ2A ] +SPQ3: SETOM INHIBIT ;A SHOULD HAVE THE STRING IN IT + JRST (F) + +SPQ2E: %WTA BISER + MOVEM A,I2 + JRST SPQ2C + + +SPQNERR: PUSH FLP,[SPQ1B] +SPQCNR: WTA [BAD "CNT" ARGUMENT TO STRING OPERATION!] + MOVEM A,CNT + SETOM CNTP + POPJ FLP, + +;Calculates word address and byte-number within word or first character +SPQFL.: MOVE D,NI2 + IDIVI D,5 + MOVEM R,BY2 ;0-ORIGINED BYTE-NO WITHIN WORD + STRWDNO F,A ;WORD-INDEX-IN-ARRAY + JRST SPQFL1 + ADD D,F + HRRZ F,.ARRAY STR/:ARRAY ;GETS TTSAR?? + ADD D,F +SPQFL2: MOVEM D,WD2 ;ADDRESS OF FIRST WORD TO FROBULATE + MOVE A,N + JRST (T) + +SPQFL1: ADDI D,(F) ;PURE FIXNUM HAS ACTUAL ADDRESS + JRST SPQFL2 + + + +SUBTTL STRING-FILL + +.ENTRY STRING-FILL LSUBR 003006 + TDZA R,R +.ENTRY STRING-FILL-N LSUBR 003006 + MOVEI R,.ATOM T + MOVEI D,4T.FILL + PUSH FXP,D ;"OPERATION" is 0 for FILL + PUSH FXP,R70 ;"BKWP" is null too + PUSH FXP,R ;"NUMCFL" + JSP F,SPQFL% + SKIPN N + JRST SPQFL$ + JSP T,SPQFL. + JUMPE R,SFL4C + ; At this point, in the "CACHE" is: D - WD2, R - BY2, A - N +SFL4L: MOVE 5,D + HLL 5,PPSSTB(R) + MOVE C,NCH + SUBI R,5 + MOVM TT,R +SFL4A: IDPB C,5 + SOJLE A,[MOVE A,S2 + JRST SPQFL$] + AOJL R,SFL4A + ADDM TT,NI2 + AOS D,WD2 + SETZB R,BY2 +SFL4C: IDIVI A,5 + MOVEM B,N + JUMPE A,SFLE1 + MOVE T,[004020100402] + MUL T,NCH ;5 COPIES OF THE BYTE IN QUESTION + CAIE T,0 + TLO TT,400000 + MOVEM TT,(D) + HRLI F,(D) + HRRI F,1(D) + ADD D,A + MOVEM D,WD2 + SOJE A,SFLE1 + BLT F,-1(D) +SFLE1: MOVE A,N + JRST SFL4L + + + +SUBTTL STRING-SEARCH-... for LISPM compatibilities + + +.ENTRY STRING-SEARCH-SET LSUBR 003004 + TDZA F,F +.ENTRY STRING-REVERSE-SEARCH-SET LSUBR 003004 + MOVEI F,LISPMBKWP + MOVEI D,4T.SSET + JRST SSS0 +.ENTRY STRING-SEARCH-NOT-SET LSUBR 003004 + TDZA F,F +.ENTRY STRING-REVERSE-SEARCH-NOT-SET LSUBR 003004 + MOVEI F,LISPMBKWP + MOVEI D,4T.SNSET +SSS0: MOVEI R,NIL + JRST SSSC0 + +.ENTRY STRING-SEARCH-CHAR LSUBR 003004 + TDZA F,F +.ENTRY STRING-REVERSE-SEARCH-CHAR LSUBR 003004 + MOVEI F,LISPMBKWP + MOVEI D,4T.SCHAR + JRST SSC0 +.ENTRY STRING-SEARCH-NOT-CHAR LSUBR 003004 + TDZA F,F +.ENTRY STRING-REVERSE-SEARCH-NOT-CHAR LSUBR 003004 + MOVEI F,LISPMBKWP + MOVEI D,4T.SNCHAR +SSC0: MOVEI R,.ATOM T +SSSC0: PUSH FXP,D ;"OPERATION" + PUSH FXP,F ;"BACKWARDSP" FLAG + PUSH FXP,R ;"NUMCFL" + JSP F,SPQFL% ;SET UP STACK-FRAME, PUSH "INHIBIT", + SKIPN N ; AND GET STRING PTR IN A + JRST SPQLUZ + JSP T,SPQFL. ;CALCULATE WORD- AND BYTE- INDICES + MOVE 5,D ; AND LEAVE "CNT" IN A + ; AT THIS POINT, IN THE "CACHE" IS: D - WD2, R - BY2, A - N + MOVE B,OPERATION + MOVE F,SSC4TB-4(B) + MOVEM F,OPERATION + SETZ TT, + CAIL B,4T.SSET + JRST SSC6L + MOVE C,NCH ;C NOW HAS THE CHAR (IN NUMERIC FORM) + CAIL C,"a ;UPPER-CASIFY C IF NOT A "SET" OPERAT + CAILE C,"z + JRST .+2 + SUBI C,"a-"A +SSC6L: HLL 5,PPSSTB+1(R) + JRST SSC6A + +;;;FALLS THRU + +;;;FALLS THRU + +SSC6B: IBP 5 +SSC6A: LDB B,5 + CAIL B,"a ;UPPER-CASIFY B IF NOT A "SET" OPERAT + CAILE B,"z + JRST .+2 + SUBI B,"a-"A + XCT OPERATION + JRST SPQ4DONE + SOJLE A,SPQLUZ ;DECREMENTS "N" + SKIPN BKWP + AOJA TT,SSC6B + ADD 5,[0700_30] ;DECREMENT BP + SKIPGE 5 + SUB 5,[430000,,1] + SOJA TT,SSC6A + + +SSC4TB: CAMN B,C ;Continue test for SEARCH-CHAR + CAME B,C ;Continue test for SEARCH-NOT-CHAR + JSP T,SSMQL ;Continue test for SEARCH-SET + JSP T,SSNMQL ;Continue test for SEARCH-NOT-SET + +;;MUST PRESERVE A,4,5,TT +SSMQL: MOVE F,T ;"SEARCH" SKIPS 1 ON FINDING CHAR, + AOJA T,0SSMQL ; 2 ON FAILURE. "SEARCH-NOT" DOES +SSNMQL: MOVEI F,1(T) ; OPPOSITE. +0SSMQL: HRRZ D,XCH +1SSMQL: JUMPE D,(T) ;EXIT THRU (T) IF SUCCESSFUL, THRU + HLRZ C,(D) ; (F) IF NOT. + MOVE C,(C) ;GET NUMERIC VALUE? + CAIL C,"a ;UPPER-CASIFY C IF NOT A "SET" OPERAT + CAILE C,"z + JRST .+2 + SUBI C,"a-"A + CAMN B,C + JRST (F) + HRRZ D,(D) + JRST 1SSMQL + + +SUBTTL STRING-REPLACE + +;;; STRING-REPLACE &optional ( 0) ( 0) ( 0 ) + +.ENTRY STRING-REPLACE LSUBR 003006 + MOVNS T + CAIN T,5 + JRST [ PUSH P,[.ATOM T ] + JRST SR0 ] + CAIG T,5 + CAIGE T,2 + JRST WNAERE + JRST .-1(T) ;PAD OUT UNSUPPLIED ARGS WITH 0 +REPEAT 3, PUSH P,CZERO + PUSH P,R70 ;"CNTP" +SR0: MOVE T,-3(P) + EXCH T,-4(P) ;RE-ARRANGE "S2" AND "I1" + MOVEM T,-3(P) + SKIPN CNTP ;LET CNT OF () BE SAME AS 0 + SKIPE CNT + JRST .+3 + MOVE T,CZERO + MOVEM T,CNT +SR1: SKIPN .SPECIAL *RSET + JRST SR2 +;Check all argument types and ranges +IRP STR,,[S1,S2]ITM,,[I1,I2] + MOVE A,STR + MOVE B,ITM + ST2%ACK SR!STR!ER,SR!STR!EX + MOVE A,B + %WTA SR2ERM + MOVEM A,ITM + JRST SR1 +SR!STR!ER: %WTA NASTER + MOVEM A,STR + JRST CHAR1 +SR!STR!EX: + TERMIN +SR2: MOVE A,S1 + MOVE B,S2 + STRLEN T,A + STRLEN TT,B +SRFXVP==. + PUSH FXP,@I1 ;wd1 + PUSH FXP,R70 ;by1 + PUSH FXP,@I2 ;wd2 + PUSH FXP,R70 ;by2 + PUSH FXP,@CNT ;n + PUSH FXP,INHIBIT ;INHIBIT - beginning part of a LOCKI +NSRFXV==.-SRFXVP + CAMGE T,WD1 + JRST SR2A + CAMGE TT,WD2 + JRST SR2B + SUB T,WD1 ;CALCULATE "CNT", IF NOT SUPPLIED + SUB TT,WD2 + CAMGE T,TT ;PUT INTO TT MAXIMUM LEGAL "CNT", WHICH IS + MOVE TT,T ; MIN OF THE 2 "LENGTH-STARTINDEX"'s + SKIPN CNTP + MOVEM TT,N + CAMGE TT,N + JRST SR2C +;;;FALLS THRU + +;;;FALLS THRU + +SR3: SETOM INHIBIT + SKIPN N + JRST SRDONE + HRRZ F,.ARRAY STR/:ARRAY ;GETS TTSAR?? + MOVE T,WD1 + IDIVI T,5 ;CALCULATE WORD AND BYTE ADDRESS + STRWDNO D,A + SKIPA + ADD T,F ; FOR START POSITION OF MOVEMENT + ADDI T,(D) + MOVEM T,WD1 + MOVEM TT,BY1 + MOVE D,WD2 + IDIVI D,5 ;CALCULATE WORD AND BYTE ADDRESS + STRWDNO F,B ; FOR START POSITION OF SOURCE + JRST SR3A1 + ADD D,F + HRRZ F,.ARRAY STR/:ARRAY ;GETS TTSAR AGAIN + ADD D,F +SR3A2: MOVEM D,WD2 + MOVEM R,BY2 + MOVE A,N ;CNT/5 - NUMBER OF FULL WORDS OF MOVEMENT + IDIVI A,5 ;CNT\5 - NUMBER OF BYTES AFTER THAT +; The "CACHE" now has: T - WD1, TT - BY1, D - WD2, R - BY2 +; A - CNT/5, B - CNT\5 + CAMGE T,D ;SINK START ADDR IS STRICTLY BELOW + JRST SR4 ; SOURCE? + CAME T,D + JRST SR3B ;MOVING BY A DISTANCE OF < 5 CHARS? + CAMN T,R + JRST SRDONE + CAMG R,TT + JRST SRBTB + JRST SR4 + +SR3A1: ADDI D,(F) ;PURE STRING HAS ABSOLUTE ADDRESS + JRST SR3A2 + +SR3B: MOVE AR1,D ;CHECK FOR OVERLAP OF FIELDS, IF + MOVE AR1+1,R ; SOURCE ADDR IS BELOW SINK ADDR. + LSTBYTIFY AR1 + CAMG T,AR1 + JRST SRBTB ;IF SO, THEN MOVE BACKWARDSLY +SR4: JUMPE TT,SR4B ;JUMPE IF SINK START CHAR IS ON WD BDRY + +;;;FALL THRU + +;;;FALLS THRU + +;Word-align the sink string-index, in left-most byte of word +SR4L: MOVE A,N + MOVE 5,D + HLL 5,PPSSTB(R) + MOVE 4,T + HLL 4,PPSSTB(TT) +; The "CACHE" now has: T - WD1, TT - BY1, D - WD2, R - BY2, A - N +SR4A: ILDB C,5 + IDPB C,4 + SOJE A,SRDONE + AOJ R, + TLNE 4,760000 ;FILL OUT ODD START WORD IN SINK + JRST SR4A + AOS T,WD1 + SETZB TT,BY1 + CAIGE R,5 + JRST .+3 + AOS D,WD2 + SUBI R,5 + MOVEM R,BY2 + IDIVI A,5 ;RE-ADJUST THE CNT/5 AND CNT\5 REGISTERS +SR4B: JUMPE A,SR4C ;MOVE SOME "FULL" WORDS + ADDI B,5 ;DO AT LEAST 5 CHARS BY SLOW METHOD + SOJE A,SR4C ; (YES YOU LOSER, THEY CAN OVERLAP!) + HRL F,D + HRR F,T + ADD T,A + MOVEM T,WD1 ;ACCOUNT FOR MOVEMENT OF FULL WORDS + ADD D,A + MOVEM D,WD2 + JUMPN R,SR5 ;JUMP IF SOURCE NOT ON WD BDRY + SKIPE A + BLT F,-1(T) +SR4C: JUMPE B,SRDONE + MOVEM B,N + JRST SR4L ;GO TO SLOW ILDB-IDPB LOOP FOR LAST 4 CHARS + + + +SR5: MOVEM B,N + MOVEI 7,-1(T) ;7 - HIGHEST WD INTO WHICH TO MOVE + MOVN C,A ;C - NEGATIVE OF # WDS TO MOVE + MOVEI 4,(D) ;4 - HIGHEST WD FROM WHICH TO MOVE + MOVE 5,R + IMULI 5,7 ;AMOUNT BY WHICH TO LSH + MOVNI 10,-43(5) + HRLI 4,(MOVE B,(C)) + HRLI 5,(LSHC A,) + MOVE 6,[LSH A,1] + HRLI 7,(MOVEM A,(C)) + HRLI 10,(LSHC A,) + MOVE 12,[JRST SR5A] + MOVE A,@4 + ROT A,-1 + MOVE 11,.+1 + AOJLE C,4 +SR5A: SKIPN N + JRST SRDONE + MOVE T,WD1 ;RELOAD THE "CACHE" + MOVE TT,BY1 + MOVE D,WD2 + MOVE R,BY2 + JRST SR4L + +SRDONE: MOVE A,S1 + SETZB B,C + SETZB 4,5 + UNLOCKI + SUB FXP,R70+NSRFXV-1 + SUB P,R70+6 + POPJ P, + + +SRBTB: ;FIRST, CONVERT INDICES INTO "LAST BYTE" ADDRESSES +;Note that we must have T+1=TT, and D+1=R +IRP RG,,[T,D]AD,,[WD1,WD2] + LSTBYTIFY RG + MOVEM RG,AD + MOVEM 1+RG,1+AD +TERMIN + CAIN TT,4 ;JUMP IF SINK STOP CHAR IS RIGHT-ADJUSTED + JRST SR6B ; IN WORD ALREADY. + + +;Word-align the sink string-index, in left-most byte of word +SR6L: MOVE A,N + MOVE 5,D + HLL 5,PPSSTB+1(R) + MOVE 4,T + HLL 4,PPSSTB+1(TT) +; The "CACHE" now has: T - WD1, TT - BY1, D - WD2, R - BY2, A - N +SR6A: LDB C,5 + DPB C,4 + SOJE A,SRDONE + SOJ R, + ADD 4,[0700_30] ;DECREMENT BP + ADD 5,[0700_30] ;DECREMENT BP + JUMPGE 4,[JUMPGE 5,SR6A + SUB 5,[430000,,1] + JRST SR6A ] + SOS T,WD1 + MOVEI TT,4 + MOVEM TT,BY1 + JUMPGE R,.+3 + SOS D,WD2 + ADDI R,5 + MOVEM R,BY2 + IDIVI A,5 ;RE-ADJUST THE CNT/5 AND CNT\5 REGISTERS +SR6B: JUMPE A,SR6C + ADDI B,5 ;DO AT LEAST 5 CHARS BY SLOW METHOD + SOJE A,SR6C ; (YES YOU LOSER, THEY CAN OVERLAP!) + HRRO F,D ;MAKE A "PDL" TO POINT TO LAST WD TO MOVE FROM + SUB T,A + SUB D,A + MOVEM T,WD1 ;ACCOUNT FOR MOVEMENT OF "FULL" WORDS + MOVEM D,WD2 + CAIE R,4 + JRST SR7 + MOVEI 3,(T) ;# WDS BETWEEN SOURCE AND SINK START + SUBI 3,(D) + HRLI 3,(POP F,(F)) + MOVE 5,[JRST SR6C] + MOVE 4,.+1 + SOJGE A,3 ;A SIMPLE "POP" LOOP FOR BLT-BACKWARDS +SR6C: JUMPE B,SRDONE + MOVEM B,N + JRST SR6L + + +;;; SHIFTING CHARS, EN PASSANT, BY AN AMOUNT NOT A MULTIPLE OF 5 + +SR7: MOVEM B,N + MOVEI 3,(A) ;3 - # WDS TO MOVE + MOVEI 4,(D) ;SOURCE START ADDR + MOVEI 10,1(T) ;SINK START ADDR + MOVE 6,R + SUBI 6,4 + IMULI 6,7 ;AMOUNT BY WHICH TO RIGHT-SHIFT + MOVNI 11,43(6) + HRLI 4,(MOVE A,(C)) + HRLOI 5,(LSH A,) + HRLI 6,(LSHC A,) + MOVE 7,[ANDCMI B,1] + HRLI 10,(MOVEM B,(C)) + HRLI 11,(LSHC A,) + MOVEM 13,CNTP ;FOO,FOO + MOVE 13,[JRST SR7A] + MOVE B,@4 + MOVE 12,.+1 + SOJGE C,4 +SR7A: MOVEI 13,NIL + EXCH 13,CNTP ;FOO,FOO + SKIPN N + JRST SRDONE + MOVE T,WD1 ;RELOAD THE "CACHE" + MOVE TT,BY1 + MOVE D,WD2 + MOVE R,BY2 + JRST SR6L + + +SR2C: MOVE A,CNT + WTA ["CNT" OUT OF RANGE - STRING-REPLACE!] + MOVEM A,CNT + SETOM CNTP +SR2CX: SUB FXP,R70+NSRFXV + JRST SR1 + +SR2A: MOVE A,I1 + %WTA SR2ERM + MOVEM A,I1 + JRST SR2CX +SR2B: MOVE A,I2 + %WTA SR2ERM + MOVEM A,I2 + JRST SR2CX + + + +FASEND diff --git a/src/lspsrc/vector.75 b/src/lspsrc/vector.75 new file mode 100755 index 00000000..2dd684a7 --- /dev/null +++ b/src/lspsrc/vector.75 @@ -0,0 +1,324 @@ +;;; 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)) + +(defmacro dolist-with-index ((var form index) &rest body &aux dummy decls) + (setq decls (cond ((and body + (not (atom (car body))) + (eq (caar body) 'DECLARE)) + (prog2 () (cdar body) (pop body))))) + (cond (index (push `(FIXNUM ,INDEX) decls) + (setq index (ncons `(,INDEX 0 (1+ ,INDEX)) )))) + (and decls (setq decls (ncons `(DECLARE ,.decls)))) + (si:gen-local-var dummy) + `(DO ((,DUMMY ,FORM (CDR ,DUMMY)) (,VAR) ,.index ) + ((NULL ,DUMMY)) + ,@decls + (SETQ ,VAR (CAR ,DUMMY)) ,.BODY)) + + +(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-with-index (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)))) + + diff --git a/src/nilcom/cnvd.2 b/src/nilcom/cnvd.2 new file mode 100755 index 00000000..97bfe338 --- /dev/null +++ b/src/nilcom/cnvd.2 @@ -0,0 +1,138 @@ +;;; CNVD -*-Mode:Lisp;Package:SI;Lowercase:T-*- +;;; **************************************************************** +;;; ***** NIL ******** Certify-no-var-dependency/| ***************** +;;; **************************************************************** +;;; ** (c) Copyright 1981 Massachusetts Institute of Technology **** +;;; **************************************************************** + +(herald CNVD /2) + +#M (include ((lisp) subload lsp)) + +#M (eval-when (eval compile) + (subload SHARPCONDITIONALS) + ) + +#+(or LISPM (and NIL (not MacLISP))) + (globalize "Certify-no-var-dependency/|") + + +(declare (special BAD-VARS BOUND-VARS ALL-LOCALS) + (genprefix |Cnvd|) + #M (setq DEFMACRO-FOR-COMPILING () )) + + + + +(DEFUN |Certify-no-var-dependency/|| (FORM) + ; This functions says "yes" if the evaluation of FORM does not depend upon + ; any of the variables in BAD-VARS, and where ALL-LOCALS is a flag with + ; non-null meaning that there are no special variables in the BAD-VARS + ; Requires these three special variables to be bound by the caller: + ; BAD-VARS (sart at list of variables for which dependency is checked) + ; BOUND-VARS (start at () ) + ; ALL-LOCALS (start at 'T) + (PROG (X) + A (COND ((ATOM FORM) ;True iff FORM can be + (RETURN (COND ((NOT (SYMBOLP FORM))) ; guaranteed not have + ((MEMQ FORM BOUND-VARS)) ; any free references + ((MEMQ FORM BAD-VARS) () ) ; to any variable in + ('T))))) ; BAD-VARS + (LET (FL) + (ERRSET (SETQ FORM (MACROEXPAND FORM) FL 'T) () ) + (IF (NULL FL) (RETURN () ))) + ;;Find out if recursing on args is all that's needed (and maybe + ;; do a little work along the way!) + (IF (COND + ((NOT (ATOM (CAR FORM))) + (COND + ((EQ (CAAR FORM) 'LAMBDA) + (LET ((BOUND-VARS (IF (ATOM (CADAR FORM)) + (CONS (CADAR FORM) BOUND-VARS) + (APPEND (CADAR FORM) BOUND-VARS)))) + (|Certify-no-var-dependency/|| `(PROGN ,.(cddar form))))) + ((SETQ X (MACROEXPAND-1* (CAR FORM))) + (SETQ FORM (CONS (CAR X) (CDR FORM))) + (GO A)) + ('T (RETURN () )))) + ((SYMBOLP (CAR FORM)) + (IF (EQ (CAR FORM) 'QUOTE) + (RETURN 'T) + (IF (MEMQ (CAR FORM) '(FUNCTION *FUNCTION)) + (IF (ATOM (CADR FORM)) + (RETURN 'T) + (PROG2 (SETQ FORM (CADR FORM)) (GO A))))) + #-Lispm (+internal-try-autoloadp (car form)) + (COND ((EQ (GET (CAR FORM) '|side-effectsp/||) '|mmcdrside/||) + ;;Note how this cooperates with the established + ;; convention described in MACAID for side-effectsp/| + 'T) + #M ((NOT (SYSP (CAR FORM))) () ) + ((|APPLICABLEP-cnvd/|| (CAR FORM)) + (COND ((MEMQ (CAR FORM) '(FUNCALL APPLY MAPC MAP MAPF + MAPCON MAPLIST MAPATOMS + MAPCAR MAPCAN *APPLY)) + (IF (AND (NOT (ATOM (CADR FORM))) + (SYMBOLP (CADADR FORM))) + (|Certify-no-var-dependency/|| + `(,(cadadr form) () )))) + ((MEMQ (CAR FORM) '(EVAL *EVAL READ *READ)) () ) + ('T))) + ((MEMQ (CAR FORM) '(OR AND SETQ PSETQ PROG1 PROG2 PROGN + CATCH *CATCH CATCHALL CATCH-BARRIER + ERRSET UNWIND-PROTECT ))) + ((OR (MEMQ (CAR FORM) '(STATUS SSTATUS SIGNP)) + (AND (EQ (CAR FORM) 'DO) (SYMBOLP (CADR FORM)))) + (SETQ FORM (CDR FORM)) + 'T))) + ('T (RETURN () ))) + (RETURN (|map-cnvd/|| (CDR FORM) 'T))) + (RETURN + (COND ((NOT (SYMBOLP (CAR FORM))) () ) + ((EQ (CAR FORM) 'COND) + (DO ((Y (CDR FORM) (CDR Y))) + ((NULL Y) 'T) + (IF (NOT (|map-cnvd/|| (CAR Y) 'T)) (RETURN () )))) + ((EQ (CAR FORM) 'PROG) + (LET ((BOUND-VARS (APPEND (CADR FORM) BOUND-VARS))) + (|map-cnvd/|| (CDDR FORM) () ))) + ((AND (EQ (CAR FORM) 'DO) + (OR (NULL (CADR FORM)) (NOT (ATOM (CADR FORM))))) + (SETQ X (MAPCAR #'(LAMBDA (X) + (IF (ATOM X) + (LIST X) + (LIST (CAR X) (CADR X) (CADDR X)))) + (CADR FORM))) + (AND (|map-cnvd/|| (MAPCAR #'CADR X) 'T) + (LET ((BOUND-VARS (NCONC (MAPCAR 'CAR X) BOUND-VARS))) + (AND (|map-cnvd/|| (MAPCAR #'CADDR X) 'T) + (|map-cnvd/|| (CDDDR FORM) () ))))) + ((MEMQ (CAR FORM) '(CASEQ TYPECASEQ)) + (COND ((NOT (|Certify-no-var-dependency/|| (CADR FORM))) () ) + ((DO ((Y (CDDR FORM) (CDR Y))) + ((NULL Y) 'T) + (IF (NOT (|map-cnvd/|| (CDAR Y) 'T)) + (RETURN () )))))) + (ALL-LOCALS (|map-cnvd/|| (CDR FORM) 'T)) + ;;;If all the BAD-VARS are local, then this line will permit + ;;; the use of random functions in FORM, since there can be no + ;;; non-lexical variable dependencies. + )))) + + + +(defun |APPLICABLEP-cnvd/|| (x &aux (fbp (fboundp x))) + (and fbp + #-MacLISP (subrp (fsymeval x)) + #+MacLISP (not (memq (car fbp) '(FEXPR FSUBR))) + #+Lispm (NOT (MEMQ X '(COND PROG SETQ OR AND STATUS SSTATUS DO PSETQ + DO-NAMED ERRSET CATCH *CATCH CATCHALL))) + )) + + +(defun |map-cnvd/|| (form symbolp) + (do ((y form (cdr y))) ;Requires two vars to be setup + ((null y) 'T) ; BAD-VARS, and BOUND-VARS + (and (not (|Certify-no-var-dependency/|| (car y))) + (or symbolp (not (symbolp (car y)))) + (return () ))))