rAez7uAD =!C%],`T@%=y&(d-"\mL>%&(m" )C4Ci G#.(t0F%(WYG&x"H aE%G2<`$DWB[4@]2\HJp]i>0V#a1I<`*\p407ND KZ@*`/`%M2`$\c1&)\&`c.],\?4@Y'@"Dok`:8@a:m"T'3q\wh7Hs$D0 nY ]}\*X" EY]&e`$Xg2ֱ5P2%(^Zȑ4`g2Mj`&d%03%g3X<$qX '%kV}*txop7PkV~:(tx7I7Pm Mi"LRx}E/(8u&`C,9,l$o32@=|88u4*@ L47/xu4&T,+8+L/xu4"T3Tk/x3$@9W򊖍e/xu&x.\(I9)Hu&x0@g )@G7H/; -*- Package:SI; Mode:LISP -*- ; Common IO routines, the mostly file-system independent I/O stuff. (eval-when (eval load compile) (globalize "STANDARD-INPUT")) (defvst LOAD-FRAME NAME VASLP AUTHOR CREATION-DATE VERSION-NUMBER EXIT-FORMS TRUENAME INPUT-STREAM READER PRINT-STREAM PRINTER ECHO-STREAM) (defvar LOAD-STACK (cons-a-LOAD-FRAME name "Terminal Input" VASLP () STREAM STANDARD-INPUT AUTHOR () CREATION-DATE () VERSION-NUMBER 0 NEXT () READER 'READ PRINT-STREAM STANDARD-OUTPUT) "A stack of load frames for the files currently being loaded, bound by LOAD") (defvar INFILE () "Compatibility stream, acts like INFILE in MacLisp, generally by indirecting through STANDARD-INPUT") (defvar LOAD-FRAME () "The frame for the file being LOADed, or NIL if no LOAD is in progress") (defvar LOADING-MESSAGES-STREAM () "If non-nil, a stream to print loading messages to") (defun make-load-frame (file-spec options &aux truename) (cons-a-LOAD-FRAME VASLP (vaslp file-spec) INPUT-STREAM (if (not vaslp) (open (file-spec)) (probe-stream file-spec)) ;(temporary stream) TRUENAME (setq truename (truename probe-stream)) VERSION-NUMBER (version-number truename) CREATION-DATE (send probe-stream ':creation-date) AUTHOR (send probe-stream ':file-author) PRINT-STREAM (decode-options ':PRINT options) ECHO-STREAM (decode-options ':ECHO options) EXIT-FORMS () NAME (filename truename) READER '(or (decode-options ':READER options) READ) PRINTER '(or (decode-options ':PRINTER options) 'PRINT))) (defun LOAD (file-spec &optional options) "Load in a file, compiled or uncompiled Options: :SILENT -- Don't print a loading message :PRINT -- Print the results of the evaluations :PRINTER -- Printer to use instead of the default :ECHO -- Stream to echo output to " (let* ((LOAD-FRAME (make-load-frame file-spec options)) (old-standard-input STANDARD-INPUT) (STANDARD-INPUT (or (load-frame-input-stream load-frame) STANDARD-INPUT)) (LOAD-STACK (cons LOAD-FRAME LOAD-STACK))) (if (and (not (null LOADING-MESSAGES-STREAM)) (not (decode-option ':SILENT options))) (catch-print (format LOADING-MESSAGES-STREAM "~&;Loading ~A from ~A" (load-frame-name LOAD-FRAME) (load-frame-truename LOAD-FRAME)))) (setf (load-frame-print-stream LOAD-FRAME) print) (unwind-protect (progn (if (load-frame-vaslp LOAD-FRAME) (vasload (load-frame-name LOAD-FRAME)) (funcall (or TOP-LEVEL-LOOP 'TOP-LEVEL-LOOP) LOAD-FRAME))) (push LOAD-FRAME LOADED-FILES)) ;Only if successful, not if aborted (mapc 'EVAL (load-frame-exit-forms)) (setf (load-frame-exit-forms LOAD-FRAME) 'DONE) ;Don't GC-protect gubbish (setq STANDARD-INPUT old-standard-input) ;In case we interrupt out of ;the CLOSE, below (if (load-frame-input-stream LOAD-FRAME) (close (load-frame-input-stream LOAD-FRAME))))) ;;; EVAL -*- Package:EVAL; Mode:LISP -*- ;;; ************************************************************** ;;; **************** EVAL - the NIL interpreter ***************** ;;; ************************************************************** ;;; ** (C) Copyright 1980 Massachusetts Institute of Technology ** ;;; ****** This is a READ-ONLY file! (All writes reserved) ******* ;;; ************************************************************** (HERALD EVAL) (COMMENT DECLARATIONS AND INITS) (DECLARE (@DEFINE SI:SF-DEFUN)) (declare (special eval:blintz eval:cln eval:lexical-cln eval:progs eval:special-decls-l eval:arg1 eval:arg2 eval:arg3 eval:arg4 eval:evalframes eval:baktrace-info eval:trace-level eval:traced-functions)) (defun eval:eval-reset () (setq eval:progs () eval:special-decls-l () eval:blintz () eval:lexical-cln 0 eval:cln 0 eval:trace-level 0 eval:evalframes () eval:baktrace-info () eval:traced-functions () ) (setq si:4v-enable ()) ;Don't worry about this until later. 'EVAL:EVAL-RESET) (eval:eval-reset) (eval-when (compile) (setq DEFMACRO-CHECK-ARGS ())) ;(eval-when (compile eval) ; (or (get 'DEFVST 'MACRO) ; (load `(,(cond ((status feature its) '(DSK NILSRC)) ; ((status feature dec20) '(PS MACLISP)) ; ((status feature sail) '(DSK (MAC LSP))) ; ((status feature dec10) '(LISP))) ; DEFVST)))) ) ;;; A PROGinfo node exists for each active PROG or DO. ;;; Tragically, we can't use DEFVST here, although let's hope one day we can. ; (defvst PROGinfo name id form cln) (defmacro cons-a-PROGinfo (&rest inits) (let (name id form cln) (do ((l inits (cddr l))) ((null l)) (caseq (car l) (NAME (setq name (cadr l))) (ID (setq id (cadr l))) (FORM (setq form (cadr l))) (CLN (setq cln (cadr l))) (T (error '|Losing CONS-A-PROGINFO| inits)))) `(VECTOR ,name ,id ,form ,cln))) (defmacro PROGinfo-name (x) `(VREF ,x 0)) (defmacro PROGinfo-id (x) `(VREF ,x 1)) (defmacro PROGinfo-form (x) `(VREF ,x 2)) (defmacro PROGinfo-cln (x) `(VREF ,x 3)) (defmacro prog-return-marker () ''prog-return-marker) ;;; This weird macro is needed by SPREAD-AND-APPLY, LET, and DO to get ;;; stack-allocated vectors. (LET-VECTOR-S ((X N)) -BODY-) binds X to a ;;; VECTOR-S of length N in -BODY-. (defmacro LET-VECTOR-S (let-list &REST body) (if (cdr let-list) (setq body `((DECLARE (SPECIAL ,(caar let-list))) (LET-VECTOR-S ,(cdr let-list) ,@body)))) `(SI:FUNCALL* ,(cadar let-list) (FUNCTION #-MACLISP (LAMBDA (&REST ,(caar let-list)) ,@body) #+MACLISP ,(let ((g (gensym))) `(LAMBDA ,g (LET ((,(caar let-list) (VECTOR-S-IFY ,g))) ,@body))) ))) #-NIL (defmacro GLOBAL:PROGV (vars vals &REST body) `(PROGV (EVAL:PROGVIFY ,vars) (SEQUENCE-TO-LIST ,vals) ,@body)) ; Permit lambda-binding of T and NIL (defun eval:progvify (oldvars &AUX (vars (sequence-to-list oldvars))) (do ((v vars (cdr v))) ((null v) vars) (cond ((null (car v)) (rplaca v sim:NIL-photon)) ((eq (car v) 'T) (rplaca v sim:T-photon))))) ; Kludgosity galore!!! Note arg must be side-effectless. #-NIL (defmacro SYMBOLIFY (x) `(COND ((NULL ,x) SIM:NIL-PHOTON) ((EQ ,x 'T) SIM:T-PHOTON) (,x))) #+NIL (defmacro SYMBOLIFY (x) x) (comment EVAL) (defun EVAL (eval:form-to-eval) (declare (special eval:evalframes eval:trace-level)) (typecaseq eval:form-to-eval ((CONSTANT CHARACTER VECTOR STRING BITS FIXNUM FLONUM SMALL-FLONUM) eval:form-to-eval) (SYMBOL (symeval-lexically eval:form-to-eval)) ((PAIR EXTEND) (let ((eval:evalframes eval:evalframes) (eval:baktrace-info eval:baktrace-info) (eval:trace-level eval:trace-level) (eval:cln eval:cln) (eval:lexical-cln eval:lexical-cln)) (prog (eval:funcell eval:list-of-args eval:tracedp) RETRY (cond ((extendp eval:form-to-eval) (and (numberp eval:form-to-eval) (return eval:form-to-eval)) (return (error-1 '|EXTENDed data not yet EVAL'able| 'EVAL eval:form-to-eval))) ((symbolp (car eval:form-to-eval)) (setq eval:funcell (SI:SPECIAL-FORMP (car eval:form-to-eval))) (cond (eval:funcell (if *rset (push (list 'EVAL (length eval:evalframes) eval:form-to-eval 0) eval:evalframes)) (setq eval:funcell (vref SI:SPECIAL-FORM-FUNS eval:funcell) eval:list-of-args (list (cdr eval:form-to-eval))) (go XIT)) ((null (setq eval:funcell (si:fsymeval-subr (CAR eval:form-to-eval)))) (error-1 'LOF 'EVAL (car eval:form-to-eval)) (go RETRY))) (if (eq (si:subr-documentation eval:funcell) 'MACRO) (return (eval (funcall (si:subr-descriptor eval:funcell) eval:form-to-eval)))) (setq eval:cln (1+ eval:cln) eval:lexical-cln eval:cln)) ((pairp (car eval:form-to-eval)) ;[Ought to macroexpand!] (if (not (eq (caar eval:form-to-eval) 'LAMBDA)) (go BADF)) (setq eval:funcell (car eval:form-to-eval))) ('T (go BADF))) (cond (*rset (push (list 'EVAL (length eval:evalframes) eval:form-to-eval 0) eval:evalframes) (if (symbolp (car eval:form-to-eval)) (push (car eval:form-to-eval) eval:baktrace-info)))) (setq eval:list-of-args (mapcar 'eval (cdr eval:form-to-eval))) XIT (cond ((and (symbolp (car eval:form-to-eval)) (get (car eval:form-to-eval) 'NIL-TRACED)) (eval:cr+tab-to (setq eval:trace-level (1+ eval:trace-level)) si:error-stream) (oustr " Entering " si:error-stream) (prin1 (car eval:form-to-eval) si:error-stream) (ouch ~/ si:error-stream) (prin1 eval:list-of-args si:error-stream) (setq eval:tracedp 'T))) (setq eval:list-of-args (apply eval:funcell eval:list-of-args)) (cond (eval:tracedp (eval:cr+tab-to eval:trace-level si:error-stream) (oustr " Exiting " si:error-stream) (prin1 (car eval:form-to-eval) si:error-stream) (ouch ~/ si:error-stream) (prin1 eval:list-of-args si:error-stream))) (return eval:list-of-args) BADF (return (error-1 "Unevaluable datum" 'EVAL eval:form-to-eval)))))) ) (defun symeval-lexically (eval:sym) (let ((eval:sym+ (symbolify eval:sym))) (cond (si:4v-enable (error-1 'ARGHH! 'SYMEVAL eval:sym)) ((or (not (boundp eval:sym+)) (eq (symeval eval:sym) *:unbound-v)) (error-1 "Unbound variable" 'SYMEVAL eval:sym)) ((symeval eval:sym+))))) (defun set-lexically (eval:sym eval:val) (let ((eval:sym+ (symbolify eval:sym))) (cond (si:4v-enable (error-1 'ARGHH! 'SET (list eval:sym eval:val))) ((set eval:sym+ eval:val))))) (defun eval:which-cell (eval:sym) (prog (eval:lcbi eval:scbi eval:lb-cln eval:sb-cln) ; Local-Cellcluster-Blintz-Index, and Special-... ; Local-Binding-Level-Number and Special-... (cond ((or (null (setq eval:lcbi (eval:get-blintz-index eval:sym () () ))) (zerop (setq eval:lb-cln (or (cadr (assq eval:lcbi eval:blintz)) 0)))) 'SPECIAL) ((or (null (setq eval:scbi (eval:get-blintz-index eval:sym 'T () ))) (zerop (setq eval:sb-cln (or (cadr (assq eval:lcbi eval:blintz)) 0)))) 'LOCAL) ;Drats! two different kinds of bindings extant! ((> eval:sb-cln eval:lb-cln) 'SPECIAL) ((not (< eval:lb-cln eval:lexical-cln)) 'LOCAL) ((error-1 "Free variable can't cross local bindings (in simulator)" 'SYMEVAL eval:sym))))) (defun eval:get-blintz-index (sym specialp function-cell-p) (cond (function-cell-p (error-1 "No BLINTZ numbers for function-cells in simulator" 'eval:get-blintz-index sym)) ((get sym (cond (specialp 'SPECIAL-blintz-index) ('T 'LOCAL-blintz-index)))))) (defun BOUNDP (eval:x) (and (boundp eval:x) (not (eq eval:x *:unbound-v)) *:truthity)) (defun SYMEVAL (eval:x) (symeval (symbolify eval:x))) (comment APPLY) ;;; Apply a function to a list of arguments ;;; "function" must be either a symbol, or a lambda-expression, ;;; or a NIL subr-object (defun APPLY (eval:fun eval:arglist) (prog () RE-APPLY (return (cond ((symbolp eval:fun) ;Allow case of "(APPLY 'EQ FOO)" (cond ((fboundp eval:fun) (setq eval:fun (si:fsymeval-subr eval:fun))) ((SI:SPECIAL-FORMP eval:fun) (error-1 "Special forms not applicable" 'APPLY eval:fun)) ('T (error-1 'LOF 'APPLY eval:fun))) (go RE-APPLY)) ((subrp eval:fun) (si:apply-subr eval:fun eval:arglist)) ((applicablep eval:fun) ;General syntax check for LAMBDA (eval:spread-and-apply (cadr eval:fun) eval:arglist (cddr eval:fun))) ('T (error-1 'LOF 'APPLY eval:fun)))))) (defun FUNCALL (eval:arg1 &REST eval:RESTV) (apply eval:arg1 eval:RESTV)) ;;; SPREAD-AND-APPLY ;;; Takes a bound-variable-list (a "lambda-list") as first arg, ;;; a list of arguments as second arg, ;;; a symbol, or list for progn-evaluation, as third arg, the "body" of ;;; the function. ;;; Loops over all variables doing the appropriate ;;; settings after binding all variables in the lambda-list to UNBOUND ;;; Then does the progn-evaluation (or applies the symbol) ;;; VVPUSH - local macro: push variable name and tentative value ;;; onto eval:vars, eval:vals. (defmacro eval:vvpush (sym) (let ((setelt #M 'LIST-SETELT #N 'VREF)) (if (symbolp sym) `(PROGN (,setelt EVAL:VARS EVAL:N ,sym) (,setelt EVAL:VALS EVAL:N (IF (BOUNDP ,sym) (SYMEVAL-LEXICALLY ,sym) *:UNBOUND-V)) (SETQ EVAL:N (1+ EVAL:N))) `(LET ((EVAL:VAR ,sym)) (,setelt EVAL:VARS EVAL:N EVAL:VAR) (,setelt EVAL:VALS EVAL:N (IF (BOUNDP EVAL:VAR) (SYMEVAL-LEXICALLY EVAL:VAR) *:UNBOUND-V)) (SETQ EVAL:N (1+ EVAL:N)))))) ;There ought to be a better way to do this... (declare (special eval:lambdalist eval:args eval:funbody eval:vars eval:vals eval:n)) (defun eval:spread-and-apply (eval:lambdalist eval:args eval:funbody) (let ((eval:n 0) (eval:ezflag 'T)) (declare (special eval:n)) ;Avoid funarging. (do ((bvl eval:lambdalist (cdr bvl)) (mode ()) (x)) ((atom bvl)) (setq x (car bvl)) (cond ((memq x '(&OPTIONAL &AUX)) (setq mode x eval:ezflag () )) ((eq x '&REST) (setq mode () eval:ezflag () )) ((symbolp x) (setq eval:n (1+ eval:n))) ((pairp x) (setq eval:ezflag ()) (eval:destructure (function (lambda (var ignore) (setq eval:n (1+ eval:n)))) (if mode (car x) x) () ) ;slight waste (and mode (cddr x) (setq eval:n (1+ eval:n)))) ((error-1 'ILL 'APPLY eval:lambdalist)))) (let ((eval:special-decls-l eval:special-decls-l) (eval:cln eval:cln) (eval:blintz eval:blintz)) (cond (eval:ezflag (if (not (= (list-length eval:lambdalist) (length eval:args))) (error-1 'WNA 'APPLY (list eval:lambdalist eval:args))) (eval:update-blintz eval:lambdalist eval:funbody 'APPLY) (progv eval:lambdalist eval:args (eval:iprogn eval:funbody))) ('T (let-vector-s ((eval:vars eval:n) (eval:vals eval:n)) (declare (special eval:vars eval:vals eval:n)) ;Avoid FUNARGing. ;Compute initial vars and vals for the PROGV. (setq eval:n 0) (do ((eval:bvl eval:lambdalist (cdr eval:bvl)) (eval:mode () ) (eval:x)) ((atom eval:bvl) (if eval:bvl (error-1 'ILL 'APPLY eval:lambdalist)) eval:n) (setq eval:x (car eval:bvl)) (cond ((memq eval:x '(&OPTIONAL &AUX)) (setq eval:mode eval:x)) ((eq eval:x '&REST) (setq eval:mode () )) ((null eval:x)) ((symbolp eval:x) (eval:vvpush eval:x)) ((pairp eval:x) (eval:destructure (function (lambda (eval:x eval:ignore) (eval:vvpush eval:x))) (if eval:mode (car eval:x) eval:x) () ) (and eval:mode (cddr eval:x) (eval:vvpush (caddr eval:x)))) ((error-1 'ILL 'APPLY eval:lambdalist)))) (progv eval:vars eval:vals ;The following PROG deposits values into variables. (prog (eval:bvl eval:argl eval:argv eval:i eval:nargs eval:item) RETRY (cond ((listp eval:args) (setq eval:argl eval:args eval:argv () eval:nargs (list-length eval:argl))) ((vectorp eval:args) (if (zerop (vector-length eval:args)) (setq eval:argl () eval:argv () eval:nargs 0) (setq eval:argl () eval:argv eval:args eval:nargs (vector-length eval:argv)))) ((setq eval:args (error-1 'WTA 'APPLY eval:args)) (go RETRY))) (setq eval:bvl eval:lambdalist eval:i 0) ;Index into eval:argv; arg count. LOOP ;Process an ordinary argument. (if (atom eval:bvl) (go EXIT)) (pop eval:bvl eval:item) (cond ((eq eval:item '&OPTIONAL) (go OPT-LOOP)) ((eq eval:item '&REST) (go REST)) ((eq eval:item '&AUX) (go AUX-LOOP)) ((>= eval:i eval:nargs) ;Too few args supplied? (error-1 'WNA 'APPLY (list eval:lambdalist eval:args)) (go EXIT)) ((eval:destructure (function set-lexically) eval:item (if eval:argv (vref eval:argv eval:i) (car eval:argl))))) (setq eval:i (1+ eval:i) eval:argl (cdr eval:argl)) (go LOOP) OPT-LOOP ;Process an optional argument. (if (atom eval:bvl) (go EXIT)) (pop eval:bvl eval:item) (cond ((eq eval:item '&OPTIONAL) (go ERR)) ((eq eval:item '&REST) (go REST)) ((eq eval:item '&AUX) (go AUX-LOOP)) ((symbolp eval:item) (set-lexically eval:item (if (< eval:i eval:nargs) (if eval:argv (vref eval:argv eval:i) (car eval:argl)) () ))) ((or (not (listp eval:item)) (not (listp (cdr eval:item))) (and (cddr eval:item) (or (not (listp (cddr eval:item))) (not (symbolp (caddr eval:item))) (cdddr eval:item)))) (go ERR)) ((< eval:i eval:nargs) (eval:destructure (function set-lexically) (car eval:item) (if eval:argv (vref eval:argv eval:i) (car eval:argl))) (if (caddr eval:item) (set-lexically (caddr eval:item) *:truthity ))) ((eval:destructure (function set-lexically) (car eval:item) (eval (cadr eval:item))) (if (caddr eval:item) (set-lexically (caddr eval:item) () )))) (setq eval:i (1+ eval:i) eval:argl (cdr eval:argl)) (go OPT-LOOP) REST (if (atom eval:bvl) (go ERR)) (pop eval:bvl eval:item) (if eval:item (if (or (not (symbolp eval:item)) (memq eval:item '(&REST &OPTIONAL &AUX))) (go ERR) (set-lexically eval:item (cond ((>= eval:i eval:nargs) () ) (eval:argv (vector-subseq eval:argv eval:i)) ((list-to-vector eval:argl)))))) (setq eval:i eval:nargs) ;All gobbled up! (if (atom eval:bvl) (go EXIT)) (pop eval:bvl eval:item) (if (not (eq eval:item '&AUX)) (go ERR)) AUX-LOOP (if (atom eval:bvl) (go EXIT)) (pop eval:bvl eval:item) (cond ((symbolp eval:item) (if (memq eval:item '(&OPTIONAL &REST &AUX)) (go ERR)) (set-lexically eval:item () )) ((or (not (listp eval:item)) (not (listp (cdr eval:item))) (cddr eval:item)) (go ERR)) ((eval:destructure (function set-lexically) (car eval:item) (eval (cadr eval:item))))) (go AUX-LOOP) ERR (error-1 'ILL 'APPLY eval:lambdalist) EXIT (if (< eval:i eval:nargs) ;Too many args supplied? (error-1 'WNA 'APPLY (list eval:lambdalist eval:args))) ) ;End of the big moby PROG! (eval:update-blintz eval:vars eval:funbody 'APPLY) (eval:iprogn eval:funbody)))))))) (comment UPDATE-BLINTZ) ;;; UPDATE-BLINTZ ;;; Takes a bound-variable-list (or vector) as first arg, ;;; a symbol, or list for progn-evaluation, as second arg, ;;; a function name (such as PROG, DO, or APPLY) as third arg ;;; Updates values of EVAL:BLINTZ, EVAL:SPECIAL-DECLS-L and EVAL:CLN (defun eval:update-blintz (seq body fun) (if si:4v-enable (cond ((atom body)) ('T (setq eval:cln (1+ eval:cln)) (and (pairp (car body)) (eq (caar body) 'DECLARE) (do ((tem (assq 'SPECIAL (cdar body)) (assq 'SPECIAL (cdr (memq tem (cdar body)))))) ((null tem)) (push (cons eval:cln (cdr tem)) eval:special-decls-l))) (do ((bvl (if (vectorp seq) () seq) (cdr bvl)) (i 0 (1+ i)) (len (length seq)) (vecp (vectorp seq)) var) ((if vecp (>= i len) (null bvl))) (setq var (if vecp (vref seq i) (car bvl))) (cond ((not (symbolp var)) (error-1 'ITM fun seq)) ((or (get var 'SPECIAL) (do ((l eval:special-decls-l (cdr l))) ((or (null l) (< (caar l) eval:lexical-cln))) (and (memq var (car l)) (return 'T)))) (push (list (or (get var 'SPECIAL-blintz-index) (putprop var (maknam (append '(S P E C I A L /[) (explodec var) '(/]))) 'SPECIAL-blintz-index)) eval:cln var) eval:blintz)) ((push (list (or (get var 'LOCAL-blintz-index) (putprop var (maknam (append '(L O C A L /[) (explodec var) '(/]))) 'LOCAL-blintz-index)) eval:cln var) eval:blintz)))))) '(si:4v-enable is ()))) (comment Special Forms) (defmacro SI:SF-DEFUN (name &REST bvl-body) (let ((name-alias (implode (append (explodec name) ;STRING-APPEND not avail. '(/ S P E C I A L / F O R M))))) `(PROGN 'COMPILE (DEFUN ,name-alias ,@bvl-body) (VSET SI:SPECIAL-FORM-FUNS (SI:SPECIAL-FORMP ',name) (SI:FSYMEVAL-SUBR ',name-alias))))) (si:sf-defun QUOTE (x) (car x)) (si:sf-defun FUNCTION (x) (car x)) (si:sf-defun COMMENT ( () ) 'COMMENT) (si:sf-defun DECLARE ( () ) 'DECLARE) #+M (si:sf-defun FASLOAD (x) (apply 'fasload x)) (si:sf-defun AND (eval:form-to-eval) (eval:and//or eval:form-to-eval *:truthity)) (si:sf-defun OR (eval:form-to-eval) (eval:and//or eval:form-to-eval () )) (defun eval:and//or (eval:forms-to-eval eval:last-val) (prog (eval:andp) (setq eval:andp eval:last-val) A (and (cond ((null eval:forms-to-eval)) ((not eval:andp) eval:last-val) ((not eval:last-val) 'T)) (return eval:last-val)) (setq eval:last-val (eval (car eval:forms-to-eval))) (pop eval:forms-to-eval) (go A))) (si:sf-defun COND (eval:form-to-eval) (do ((eval:clause eval:form-to-eval (cdr eval:clause)) (eval:pred-result)) ((null eval:clause) () ) (and (setq eval:pred-result (eval (caar eval:clause))) (return (cond ((cdar eval:clause) (eval:iprogn (cdar eval:clause))) (eval:pred-result)))))) (si:sf-defun CASEQ (eval:arg1) (eval:caseq (eval (car eval:arg1)) (cdr eval:arg1))) (defun eval:caseq (eval:last-val eval:clause) (prog (eval:type) RETRY (setq eval:type (ptr-typep eval:last-val)) (cond ((not (memq eval:type '(SYMBOL FIXNUM CHARACTER))) (error-1 'WTA 'CASEQ eval:last-val) (go RETRY))) TG (and (null eval:clause) (return () )) (and (cond ((eq (caar eval:clause) 'T)) ((null (caar eval:clause)) () ) ((not (pairp (caar eval:clause))) (eval:caseq-comp (caar eval:clause) eval:last-val eval:type)) ((do eval:item (caar eval:clause) (cdr eval:item) (null eval:item) (and (eval:caseq-comp (car eval:item) eval:last-val eval:type) (return 'T))))) (return (eval:iprogn (cdar eval:clause)))) (setq eval:clause (cdr eval:clause)) (go TG) )) (defun eval:caseq-comp (eval:item eval:last-val eval:type) (and (not (eq eval:type (ptr-typep eval:item))) (error-1 'ITM 'CASEQ (list eval:item eval:type))) (or (eq eval:item eval:last-val) (caseq eval:type ((SYMBOL CHARACTER) (eq eval:item eval:last-val)) (FIXNUM (= eval:item eval:last-val)) (T (equal eval:item eval:last-val))))) (si:sf-defun DO (eval:form-to-eval) (let (eval:vars-list eval:end-ret eval:body) (declare (special eval:vars-list eval:end-ret eval:body)) (cond ((and (car eval:form-to-eval) (symbolp (car eval:form-to-eval))) ;Test for old-style DO (setq eval:vars-list (list (list (car eval:form-to-eval) (cadr eval:form-to-eval) (caddr eval:form-to-eval))) eval:end-ret (list (cadddr eval:form-to-eval) ()) eval:body (cddddr eval:form-to-eval))) ('T (pop eval:form-to-eval eval:vars-list) (pop eval:form-to-eval eval:end-ret) (setq eval:body eval:form-to-eval))) (let-vector-s ((eval:vars (list-length eval:vars-list)) (eval:vals (length eval:vars))) (do ((eval:l eval:vars-list (cdr eval:l)) (eval:i 0 (1+ eval:i))) ((null eval:l)) (cond ((atom (car eval:l)) (setelt eval:vars eval:i (car eval:l)) ;VREF in real NIL. (setelt eval:vals eval:i ())) ('T (setelt eval:vars eval:i (caar eval:l)) (setelt eval:vals eval:i (eval (cadar eval:l)))))) (progv eval:vars eval:vals (let ((eval:special-decls-l eval:special-decls-l) (eval:cln eval:cln) (eval:blintz eval:blintz) (eval:progs eval:progs) eval:tem) (prog () (eval:update-blintz eval:vars eval:body 'DO) (eval:update-progs () eval:body) A (if (eval (car eval:end-ret)) (return (eval:iprogn (cdr eval:end-ret)))) (setq eval:tem (eval:prog-loop)) (if (not (eq eval:tem (prog-return-marker))) (return eval:tem)) (do ((eval:l eval:vars-list (cdr eval:l)) (eval:i 0 (1+ eval:i))) ((null eval:l)) (if (pairp (car eval:l)) (setelt eval:vals eval:i (eval (caddar eval:l))) (setelt eval:vals eval:i (symeval-lexically (car eval:l))))) (mapc 'SET-LEXICALLY eval:vars eval:vals) (go A))))))) ;; EVAL:DESTRUCTURE - destructure value according to pattern (defun EVAL:DESTRUCTURE (eval:func eval:pattern eval:value) (cond ((null eval:pattern)) ((symbolp eval:pattern) (funcall eval:func eval:pattern eval:value)) ((pairp eval:pattern) (or (listp eval:value) (error-1 'ILF 'DESTRUCTURE (list eval:pattern eval:value))) (eval:destructure eval:func (car eval:pattern) (car eval:value)) (eval:destructure eval:func (cdr eval:pattern) (cdr eval:value))) ((error-1 'ILF 'DESTRUCTURE (list eval:pattern eval:value))))) (si:sf-defun LET (eval:form-to-eval) (eval:spread-and-apply (cons '&OPTIONAL (car eval:form-to-eval)) () (cdr eval:form-to-eval))) (si:sf-defun DESETQ (eval:form-to-eval) (do ((eval:arglist eval:form-to-eval (cddr eval:arglist)) eval:val) ((null eval:arglist) eval:val) (if (null (cdr eval:arglist)) (error-1 'WNA 'DESETQ eval:arglist)) (eval:destructure (function set-lexically) (car eval:arglist) (setq eval:val (eval (cadr eval:arglist)))))) (si:sf-defun DEFUN (eval:form-to-eval) (let (((name . bvl-body) eval:form-to-eval) (type 'EXPR)) (cond ((pairp name) (desetq (name type) name)) ((symbolp (car bvl-body)) (pop bvl-body type))) (if (not (symbolp name)) (error-1 "Illegal function name" 'DEFUN eval:form-to-eval)) (caseq type (EXPR (fset name `(LAMBDA ,@bvl-body))) (MACRO (fset name `(MACRO LAMBDA ,@bvl-body))) (LEXPR (fset name `(LAMBDA (&REST eval:lexpr-arg &AUX (,(caar bvl-body) (LENGTH eval:fexpr-arg))) (DECLARE (SPECIAL eval:lexpr-arg)) ,(cdr bvl-body)))) (FEXPR (let ((alias (implode (nconc (explodec name) '(/ F E X P R))))) (fset alias `(LAMBDA ,@bvl-body)) (fset name `(MACRO LAMBDA (fexpr-arg) `(,',alias ',(cdr fexpr-arg)))))) (T (putprop name type `(LAMBDA ,@bvl-body)))) (if (fboundp name) ;If not recovering from error, stuff name. (*:set-leader (si:fsymeval-subr name) *:subr-name-index name)) name)) (si:sf-defun MACRO (eval:form-to-eval) (let (((name . bvl-body) eval:form-to-eval)) (and (pairp name) (setq name (car name))) (or (symbolp name) (error-1 'WTA 'MACRO eval:form-to-eval)) (fset name `(MACRO . (LAMBDA ,@bvl-body))) (*:set-leader (si:fsymeval-subr name) *:subr-name-index name) name)) (defun ARG (n) ;hack hack (declare (special eval:lexpr-arg)) (if (= n 0) (length eval:lexpr-arg) (vref eval:lexpr-arg (1- n)))) ;;; sooner or later, we'll have to make this CLOSURE etc work ;;; For now a closure is like ;;; #( ) (si:sf-defun CLOSURE (eval:form-to-eval) (and (or (atom eval:form-to-eval) (atom (cdr eval:form-to-eval)) (cddr eval:form-to-eval)) (error-1 "This case can't be simulated" 'CLOSURE eval:form-to-eval)) (let ((fun (car eval:form-to-eval)) (specvars (list-to-vector (cadr eval:form-to-eval))) (valuecells (make-list (list-length (cadr eval:form-to-eval))))) (vector-to-extend (*:change-vector-to-extend (vector *:ptr-class-closure fun specvars valuecells))))) (si:sf-defun FLEXURE (eval:form-to-eval) (error-1 "You lose, bunkie!" 'FLEXURE eval:form-to-eval)) ;;; The normal "setq" (si:sf-defun SETQ (eval:form-to-eval) (do ((eval:arglist eval:form-to-eval (cddr eval:arglist)) eval:val) ((null eval:arglist) eval:val) (and (null (cdr eval:arglist)) (error-1 'WNA 'SETQ eval:arglist)) (if (not (symbolp (car eval:arglist))) (error-1 "SYMBOL required" 'SETQ eval:arglist) (set-lexically (car eval:arglist) (setq eval:val (eval (cadr eval:arglist))))))) ;;; A parallel "setq" - all evaluations are done before any bindings (si:sf-defun PSETQ (eval:form-to-eval) (do ((eval:arglist eval:form-to-eval (cddr eval:arglist)) (eval:vals (do ((eval:arglist eval:form-to-eval (cddr eval:arglist)) eval:val) ((null eval:arglist) eval:val) (if (null (cdr eval:arglist)) (error-1 'WNA 'PSETQ eval:arglist)) (push (eval (cadr eval:arglist)) eval:val)) (cdr eval:vals)) eval:lastval) ((null eval:arglist) eval:lastval) (if (symbolp (car eval:arglist)) (set-lexically (car eval:arglist) (setq eval:lastval (car eval:vals))) (error-1 "SYMBOL required" 'PSETQ eval:arglist)))) ;;; Counterpart of SETQ for function-cells (si:sf-defun FSETQ (eval:form-to-eval) (do ((eval:arglist eval:form-to-eval (cddr eval:arglist)) eval:val) ((null eval:arglist) eval:val) (if (null (cdr eval:arglist)) (error-1 'WNA 'FSETQ eval:arglist)) (if (symbolp (car eval:arglist)) (fset (car eval:arglist) (setq eval:val (eval (cadr eval:arglist)))) (error-1 "SYMBOL required" 'FSETQ eval:arglist)))) ;;; Counterpart of nonexistant SYMEVALQ for function-cells. ;;; (FSYMEVAL 'X) gets X's special function cell, while ;;; (FSYMEVALQ X) gets its local value cell. ;;; NIL's (SYMEVAL 'X) is like SCHEME's (FLUID X), and (SYMEVALQ X) ;;; or just plain X is like SCHEME's (STATIC X) or X. See note ;;; {What good is it?} in the Revised Report on Scheme for an ;;; explanation of STATIC. (si:sf-defun FSYMEVALQ (eval:form-to-eval) (if (cdr eval:form-to-eval) (error-1 'WNA 'FSYMEVALQ eval:form-to-eval)) (fsymeval (car eval:form-to-eval))) (si:sf-defun PROG (eval:form-to-eval) (let ((eval:special-decls-l eval:special-decls-l) (eval:cln eval:cln) (eval:blintz eval:blintz) (eval:progs eval:progs) eval:tem) (cond ((atom eval:form-to-eval) (error-1 'ILF 'PROG eval:form-to-eval)) ((listp (car eval:form-to-eval))) ((symbolp (car eval:form-to-eval)) (pop eval:form-to-eval eval:tem)) ;extract name ((error-1 'ILF 'PROG eval:form-to-eval))) (eval:update-blintz (car eval:form-to-eval) (cdr eval:form-to-eval) 'PROG) (eval:update-progs eval:tem (cdr eval:form-to-eval)) (progv (car eval:form-to-eval) si:NIL* (cond ((eq (setq eval:tem (eval:prog-loop)) (prog-return-marker)) () ) ('T eval:tem))))) (defun eval:update-progs (prog-name form) ;Constructs up the PROGinfo frob for PROG and DO (push (cons-a-PROGinfo NAME prog-name ID (gensym) FORM form CLN eval:cln) eval:progs)) (defun eval:prog-loop () ;Runs the current (most recent) PROG ;GO causes throw to here, using a gensymmed catch tag, with the spot ; at which to start prog-evaling again. ;RETURN throws to here, with a pair whose car is a special marker, and ; whose cdr is the value to be returned. ;Exit is normal, by execution of RETURN, with returned value; ; is fall-thru, indicating a value of (), with internal marker. (prog (eval:prog-form) (setq eval:prog-form (PROGinfo-form (car eval:progs))) A (setq eval:prog-form (*catch (PROGinfo-id (car eval:progs)) (do ((eval:forms eval:prog-form (cdr eval:forms))) ((null eval:forms) () ) (and (pairp (car eval:forms)) (eval (car eval:forms)))))) (cond ((null eval:prog-form) (return (prog-return-marker))) ((eq (car eval:prog-form) (prog-return-marker)) (return (cdr eval:prog-form))) ('T (go A))))) (si:sf-defun GO (x) ;Cycle thru lexical PROGs, looking for tag. Error if not found (do ((pil (cond ((or (atom x) (cddr x)) () ) ('T eval:progs)) (cdr pil)) (tag (and (pairp x) (car x))) go-place prog-info) ((or (null pil) (< (PROGinfo-cln (car pil)) eval:lexical-cln)) (return (error-1 "Can't find tag" 'GO x))) (setq prog-info (car pil)) (cond ((cdr x) (cond ((not (eq (cadr x) (PROGinfo-name prog-info)))) ((setq go-place (memq tag (PROGinfo-form prog-info))) (*throw (PROGinfo-id prog-info) go-place)) ;If this is right PROG for a named GO, but tag not found, ; then abort by setting "pil" to null. ('T (setq pil () )))) ((setq go-place (memq tag (PROGinfo-form prog-info))) (*throw (PROGinfo-id prog-info) go-place))))) (si:sf-defun RETURN (eval:x) (if (null eval:progs) (error-1 "Not inside PROG or DO" 'RETURN () ) (*throw (PROGinfo-id (car eval:progs)) (cons (prog-return-marker) (eval (car eval:x)))))) (si:sf-defun RETURN-FROM (eval:x) (do ((eval:ret-val (eval (cadr eval:x))) (prog-name (car eval:x)) (pil eval:progs (cdr pil))) ((null pil) (error-1 "Not inside PROG or DO" 'RETURN-FROM prog-name)) (if (eq prog-name (PROGinfo-name (car pil))) (*throw (PROGinfo-id (car pil)) (cons (prog-return-marker) eval:ret-val))))) (si:sf-defun PROG1 (eval:form-to-eval) (eval:prog1//2 eval:form-to-eval)) ;(si:sf-defun PROJ1 (eval:form-to-eval) (eval:prog1//2 eval:form-to-eval)) (si:sf-defun PROG2 (eval:form-to-eval) (let ((eval:forms-to-eval eval:form-to-eval)) (eval (car eval:forms-to-eval)) (eval:prog1//2 (cdr eval:forms-to-eval)))) (defun eval:prog1//2 (eval:forms-to-eval) (prog (eval:val-to-return) (setq eval:val-to-return (eval (car eval:forms-to-eval))) A (pop eval:forms-to-eval) (and (null eval:forms-to-eval) (return eval:val-to-return)) (eval (car eval:forms-to-eval)) (go A))) (si:sf-defun PROGN (eval:form-to-eval) (eval:iprogn eval:form-to-eval)) (si:sf-defun PROGV (eval:forms-to-eval) (if (or (not (sequencep (cdr eval:forms-to-eval))) (not (sequencep (cddr eval:forms-to-eval)))) (error-1 'ILF 'PROGV eval:forms-to-eval) (progv (eval (car eval:forms-to-eval)) (eval (cadr eval:forms-to-eval)) (eval:iprogn (cddr eval:forms-to-eval))))) (defun eval:iprogn (eval:forms-to-eval) (prog () (if (not (listp eval:forms-to-eval)) (return (error-1 'ILF 'PROGN eval:forms-to-eval))) A (if (null (cdr eval:forms-to-eval)) (return (eval (car eval:forms-to-eval)))) (eval (car eval:forms-to-eval)) (pop eval:forms-to-eval) (go A))) (si:sf-defun CATCH (eval:form-to-eval) (*catch (eval (car eval:form-to-eval)) (eval:iprogn (cdr eval:form-to-eval)))) (si:sf-defun THROW (eval:form-to-eval) (or (= (list-length eval:form-to-eval) 2) (error-1 'WNA 'THROW eval:form-to-eval)) (*throw (eval (car eval:form-to-eval)) (eval (cadr eval:form-to-eval)))) (si:sf-defun CATCHALL (eval:form-to-eval) (let ((eval:catchallfun (eval (car eval:form-to-eval)))) (catchall '(lambda (eval:tag eval:val) (funcall eval:catchallfun eval:tag eval:val)) (eval:iprogn (cdr eval:form-to-eval))))) (si:sf-defun CATCH-BARRIER (eval:form-to-eval) (catch-barrier (eval (car eval:form-to-eval)) (eval:iprogn (cdr eval:form-to-eval)))) (si:sf-defun UNWIND-PROTECT (eval:form-to-eval) (unwind-protect (eval (car eval:form-to-eval)) (eval:iprogn (cdr eval:form-to-eval)))) (si:sf-defun EVAL-WHEN (eval:form-to-eval) (and (memq 'EVAL (car eval:form-to-eval)) (do ((eval:forms-to-eval (cdr eval:form-to-eval) (cdr eval:forms-to-eval)) (eval:last-val () (eval (car eval:forms-to-eval)))) ((null eval:forms-to-eval) eval:last-val)))) ;;This is wrong, since the comparison really ought to be with the ;;first 5 chars of the PNAME. (si:sf-defun STATUS (eval:form-to-eval) (caseq (car eval:form-to-eval) ((FEATURE FEATURES FEATU) (if (cdr eval:form-to-eval) (featurep (cadr eval:form-to-eval)) si:feature-list)) ((NOFEATURE NOFEA) (not (featurep (cadr eval:form-to-eval)))) ((TOPLEVEL TOPLE) si:toplevel-form) ((BREAKLEVEL BREAK) si:breaklevel-form) (T #+NIL-SIMULATION (apply 'STATUS eval:form-to-eval) #-NIL-SIMULATION (error-1 "Bad STATUS request" 'STATUS eval:form-to-eval)) )) (si:sf-defun SSTATUS (eval:form-to-eval) (caseq (car eval:form-to-eval) ((FEATURE FEATU) (car (push (cadr eval:form-to-eval) si:feature-list))) ((NOFEATURE NOFEA) (setq si:feature-list (delete (cadr eval:form-to-eval) si:feature-list)) (cadr eval:form-to-eval)) ((TOPLEVEL TOPLE) (setq si:toplevel-form (eval (cadr eval:form-to-eval)))) ((BREAKLEVEL BREAK) (setq si:breaklevel-form (eval (cadr eval:form-to-eval)))) (T #+NIL-SIMULATION (apply 'SSTATUS eval:form-to-eval) #-NIL-SIMULATION (error-1 "Bad SSTATUS request" 'SSTATUS eval:form-to-eval)) )) (si:sf-defun PUSH (eval:form-to-eval) (set-lexically (cadr eval:form-to-eval) (cons (eval (car eval:form-to-eval)) (eval (cadr eval:form-to-eval))))) (si:sf-defun POP (eval:x) (let ((the-cons (symeval-lexically (car eval:x)))) (set-lexically (car eval:x) (cdr the-cons)) (if (cdr eval:x) (set-lexically (cadr eval:x) (car the-cons))) (car the-cons))) (si:sf-defun TYPECASEQ (eval:form-to-eval) (eval:caseq (ptr-typep (eval (car eval:form-to-eval))) (cdr eval:form-to-eval))) (comment MAPF) (si:sf-defun MAPF (eval:form-to-eval) ;Original bvl = (result-type source-types fun &rest args) (let ( ((eval:arg2 eval:arg1 eval:arg3 . eval:restv) eval:form-to-eval) eval:temp) (setq eval:arg3 (eval eval:arg3) eval:restv (mapcar 'eval eval:restv)) (let ((args-list eval:restv) (source-types (typecaseq eval:arg1 (SYMBOL (setq eval:temp (list eval:arg1)) (rplacd eval:temp eval:temp) eval:temp) (PAIR eval:arg1) (T (error-1 'WTA 'MAPF)))) (result-type eval:arg2) (fun eval:arg3) (result-length -1) (result-max-length 17) result (fxresult 0) (flresult 0.0) ) (declare (fixnum fxresult) (flonum flresult)) (setq result (caseq result-type ((LIST NCONC) () ) (PROJ1 (car args-list)) (VECTOR (make-vector 20)) (STRING (make-string 20)) (BITS (make-bits 20)) ((+) (setq fxresult 0)) ((+$) (setq flresult 0.0)) (T (error-1 'BTS 'MAPF eval:arg2) ))) (setq source-types (mapcar '(lambda (type arg) (or (caseq type ((LIST CAR) (listp arg)) ((VECTOR STRING BITS) (eq (ptr-typep arg) type)) ((CONSTANT) 'T) ((1+ 1-) (eq (typep arg) 'FIXNUM)) ((1+$ 1-$) (eq (typep arg) 'FLONUM)) (T (error-1 'ITM 'MAPF (list type arg)))) (error-1 "Unmatched arg/type" 'MAPF (list type arg))) type) source-types args-list)) (*catch 'EVAL:MAPF-END (do ((end-flag 0 0) (current-result)) (()) (setq result-length (1+ result-length)) (setq current-result (apply fun (maplist '(lambda (arg arg-type) (caseq (car arg-type) ((CAR LIST) (and (null (car arg)) (*throw 'EVAL:MAPF-END () )) (prog2 () (caseq (car arg-type) (LIST (car arg)) (CAR (caar arg)) (T (error-1 'ITM 'MAPF (list arg arg-type)))) (rplaca arg (cdar arg)))) (STRING (cond ((not (< result-length (string-length (car arg)))) (*throw 'EVAL:MAPF-END () )) ((char (car arg) result-length)))) (VECTOR (cond ((not (< result-length (vector-length (car arg)))) (*throw 'EVAL:MAPF-END () )) ((vref (car arg) result-length)))) (BITS (cond ((not (< result-length (bits-length (car arg)))) (*throw 'EVAL:MAPF-END () )) ((bit (car arg) result-length)))) (CONSTANT (car arg)))) args-list source-types))) (caseq result-type ((LIST NCONC) (push current-result result)) (PROJ1 () ) (VECTOR (and (> result-length result-max-length) (setq result (vector-replace (make-vector (setq result-max-length (+ 20 result-max-length))) result))) (vset result result-length current-result)) (STRING (or (characterp current-result) (error-1 "Result must be a character" 'MAPF current-result)) (and (> result-length result-max-length) (setq result (fill-string (make-string (setq result-max-length (+ 20 result-max-length))) result))) (rplachar result result-length current-result)) (BITS (or (fixnump current-result) (error-1 "Result must be a fixnum" 'MAPF current-result)) (and (> result-length result-max-length) (setq result (fill-bits (make-bits (setq result-max-length (+ 20 result-max-length))) result)) (rplacbit result result-length current-result))) ((+) (setq fxresult (+ current-result fxresult))) ((+$) (setq flresult (+$ current-result flresult))) ))) (caseq result-type (LIST (nreverse result)) (NCONC (do ((l result (cdr l)) (ans () (nconc (car l) ans))) ((null l) ans))) (VECTOR (set-vector-length result result-length) result) (STRING (set-string-length result result-length) result) (BITS (set-bits-length result result-length) result) (+ fxresult) (+$ flresult) (T result))))) (comment TRACE and debugging) (sim:incompatible trace untrace baktrace bs fs) (macro TRACE (x) `(eval:trace-internal ,@(mapcar (function (lambda (y) `',y)) (cdr x)))) (defun eval:trace-internal (&rest names) (declare (special eval:traced-functions)) (cond (names (do ((i 0 (1+ i)) (name) (len (vector-length names))) ((not (< i len))) (cond ((not (si:fsymeval-subr (setq name (vref names i)))) (terpri si:error-stream) (princ name si:error-stream) (oustr " has no function cell, tracing anyway" si:error-stream))) (push name eval:traced-functions) (putprop name 'T 'NIL-TRACED)) names) (eval:traced-functions))) (macro UNTRACE (x) `(eval:untrace-internal ,@(mapcar (function (lambda (y) `',y)) (cdr x)))) (defun eval:untrace-internal (&rest funs) (or funs (setq funs (list-to-vector eval:traced-functions))) (do ((i 0 (1+ i)) (name) (len (vector-length funs))) ((not (< i len)) funs) (setq name (vref funs i)) (remprop name 'NIL-TRACED) (setq eval:traced-functions (delq name eval:traced-functions)))) (defun eval:cr+tab-to (n stream) (declare (special i)) (terpri stream) (do i n (1- i) (= i 0) (ouch ~/ stream))) (defun BAKTRACE () (terpri) (mapc '(lambda (x) (prin1 x) (oustr "_ " si:error-stream)) (cdr eval:baktrace-info)) () ) (declare (special eval:bs)) (defun BS (&OPTIONAL (k 1)) (if (or (null k) (not (boundp 'eval:bs))) (setq eval:bs -1)) (if (null k) (setq k 1)) (setq eval:bs (+ eval:bs k)) (nth eval:bs eval:evalframes)) (defun FS (&OPTIONAL (k 1)) (if (or (null k) (not (boundp 'eval:bs))) (setq eval:bs 1)) (if (null k) (setq k 1)) (setq eval:bs (- eval:bs k)) (if (< eval:bs 0) () (nth eval:bs eval:evalframes)))Z1;;; MACSIM -*-LISP-*- ;;; ************************************************************** ;;; ***** MACSIM - a NIL simulator to run under MACLISP ********** ;;; ************************************************************** ;;; ** (C) Copyright 1979 Massachusetts Institute of Technology ** ;;; ****** This is a READ-ONLY file! (All writes reserved) ******* ;;; ************************************************************** (declare (@define nil-defun macmac-defun gen-specificseqfuns gen-genericseqfun gen-nthseqfun gen-genericseqfun-gp gen-flcmpfn gen-datapredicate-macro gen-dramp-functions) ) (defun ceval macro (x) (eval (cadr x))) (ceval `(PROGN 'COMPILE (SETQ SIM:NIL-VERSION ',(caddr (truename infile))))) (defmacro IF (p c . a) `(COND (,p ,c) ,a)) (comment CHANGE MACLISP READ SYNTAX) (defun sim:sharp-macro () (let ((nchar (tyipeek))) (declare (fixnum nchar)) (cond ((= nchar 40.) (list (list-to-vector (read)))) ;open-parens ((or (= nchar 79.) (= nchar 111.) ;~O and ~o (lessp 47. nchar 58.) ;~0 ... ~9 (= nchar 88.) (= nchar 120.)) ;~X and ~x (let ((ibase (cond ((or (= nchar 79.) (= nchar 111.)) (tyi) 8.) ((or (= nchar 88.) (= nchar 120.)) (tyi) 16.) ('T (read))))) (list (read)))) ((prog2 (setq nchar (tyi)) () )) ((or (= nchar 77.) (= nchar 109.) ;~M and ~m (= nchar 78.) (= nchar 110.) ;~N and ~n (= nchar 81.) (= nchar 113.)) ;~Q and ~q (or (eval (list 'STATUS 'FEATURE (caseq nchar ((77. 109.) 'MACLISP) ((78. 110.) 'NIL) ((81. 113.) 'LISPM)))) (read)) () ) ((or (= nchar 84.) (= nchar 116.)) (list *:truthity)) ;~T, ~t ((or (= nchar 66.) (= nchar 98.)) ;~B and ~b (and (not (= (setq nchar (tyi)) 34.)) ; ~" (error-1 '|#B not followed by "| 'sim:sharp-macro nchar)) (prog (l c b ll) (declare (fixnum c ll)) (setq ll 0 c 0) A (cond ((= (setq c (tyi)) 34.) (setq b (make-bits ll)) (do i (1- ll) (1- i) (< i 0) (rplacbit b i (pop l))) (return (list b)))) (push (caseq c (48. 0) (49. 1) (T (error-1 '|#B token is bad| 'sim:sharp-macro c))) l) (setq ll (1+ ll)) (go A))) ((= nchar 61.) ;~= (cond ((= (tyipeek) 47.) ;~/ (tyi) ; flush the / (list (tyi))) ('T (let ((char (read))) (cond ((and (fixnump char) (lessp -1 (setq nchar char) 128.)) (list (ascii char))) ('T (error-1 '|losing #= form| 'sim:sharp-macro char)))) )))))) (defun sim:tilde-macro () (*:fixnum-to-character (let ((char (tyi))) (cond ((not (= char 47.)) char) ((tyi)))))) (defun sim:doublequote-macro () (do ((str (make-string 100.)) (buffer-length 100.) (index 0 (1+ index)) (char (tyi) (tyi))) ((= char 34.) (set-string-length str index)) (or (< index buffer-length) (setq buffer-length (+ buffer-length 100) str (fill-string (make-string buffer-length) str))) (and (= char 47.) (setq char (tyi))) ;"slash"? (rplachar str index (*:fixnum-to-character char)))) ;;; Note that these macro-characters can't be used until a few ;;; MACROs are defined, e.g. *:FIXNUM-TO-CHARACTER (setsyntax '/. (boole 6 (status syntax /.) 1_17.) () ) (setsyntax '/~ 'macro 'sim:tilde-macro) (setsyntax '/" 'macro 'sim:doublequote-macro) (setsyntax '/# 'splicing 'sim:sharp-macro) (comment SYSTEMIC CONSTANTS - declarations and initial settings) (declare (special *:min-fixnum *:max-fixnum *:max-floatable-integer *:min-floatable-integer *:max-flonum *:min-pos-flonum *:max-neg-flonum *:min-flonum *:bits-per-Q *:bits-per-fixnum *:bits-per-character *:bits-per-byte sim:nil-version *:bits-per-flonum-mantissa *:bits-per-flonum-exponent *:bits-per-small-flonum-mantissa *:bits-per-small-flonum-exponent *:max-small-flonum *:min-small-flonum *:truthity *:nullity *:unbound-v *:unbound-f) (special sim:load-stream sim:error-stream sim:putback-al sim:baktrace-info sim:trace-level sim:traced-functions sim:progs sim:blintz sim:cln sim:lexical-cln sim:special-decls-l sim:errsetp sim:eprintp sim:NIL* sim:UNBOUND* ) (special *:known-classes *:class-typep-index *:class-suprs-index *:class-sendi-index *:class-calli-index *:class-mthds-index *:class-descr-index *:class-size *:ptr-class-object *:ptr-class-class *:ptr-class-number *:ptr-class-complex *:ptr-class-bignum *:ptr-class-bigfloat *:ptr-class-stream *:ptr-class-closure *:ptr-class-bufferkey) (special sim:nil-reset sim:NEWdtp-marker sim:NILfun-marker sim:unique sim:constant-table sim:charob-table sim:funcall-n-lists sim:arg1 sim:arg2 sim:arg3 sim:arg4 sim:arg0 sim:maclisp-base sim:maclisp-ibase ) (fixnum (maclisp-length)) (flonum (maclisp-float)) ) (eval-when (eval compile load) (setq *:min-fixnum (^ -2 35.) ;"Systemic" constants *:max-fixnum (- -1 *:min-fixnum) *:max-floatable-integer 170141182192818631503457902219180900352. *:min-floatable-integer (minus *:max-floatable-integer) *:max-flonum 1.701411825E+38 *:min-pos-flonum 1.46936794E-39 *:max-neg-flonum -1.46936795E-39 *:min-flonum -1.701411825E+38 ;Ha, SETZ loses *:bits-per-Q 18. *:bits-per-fixnum 36. *:bits-per-character 7 *:bits-per-byte 7 *:bits-per-flonum-mantissa 27. ;Field size, assuming *:bits-per-flonum-exponent 9. ; DEC representation *:bits-per-small-flonum-mantissa 20. *:bits-per-small-flonum-exponent 7. *:max-small-flonum 9.22336325E+18 ;for <7., 20.> as above *:min-small-flonum (minus *:max-small-flonum) ) (do ((i 0 (1+ i)) (y '( *:class-typep-index *:class-suprs-index *:class-sendi-index *:class-calli-index *:class-mthds-index *:class-descr-index ) (cdr y))) ((null y) (setq *:class-size i) ) (set (car y) i)) ) (comment DEFVST macros NILfun PROGinfo NEWdtp ) (eval-when (eval) (setq DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL 'T DEFMACRO-CHECK-ARGS 'T MACRO-EXPANSION-USE 'MACROEXPANDED)) (eval-when (compile) (setq DEFMACRO-FOR-COMPILING () DEFMACRO-DISPLACE-CALL () DEFMACRO-CHECK-ARGS ())) (eval-when (compile eval) (or (get 'DEFVST 'MACRO) (load (cons (cond ((status feature its) '(DSK LIBLSP)) ((status feature dec20) '(PS MACLISP)) ((status feature dec10) '(LISP))) '(DEFVST FASL))))) ;;; Special-forms are implemented as 'SI:SPECIAL-FORMP property ;;; The table SI:SPECIAL-FORM-FUNS has corresponding subr-ptr entries ;;; or else some applicable entry (like a LAMBDA expression) ;;; A structure for NIL function-cell frobs ;;; (SUBR (name . )) For the maclisp subr (or LSUBR) ;;; (LAMBDA ) The classic LISP thing! ;;; ? (SUBST ) "substitution" macro ;;; (EXPR () ) Defer to FUNCTION-CELL of ;;; (MACRO ) Standard MACRO thingy as expr ;;; (MACRO (() . 1) ) ?? Compiled MACRO? (defvst NILfun (type = 'EXPR) args body) (defvst PROGinfo name id form cln) ;;; In the MacLISP environment, an NEWdtp object looks like it was made by: ;;; (HUNK |sim:NEWdtp-marker|) ;;; is one of: BITS, VECTOR, STRING, or EXTEND (for sequences) ;;; or one of: CONSTANT, CHARACTER, SMALL-FLONUM. ;;; for sequence'd data, is the *:total-size of the ;;; for CONSTANTs and CHARACTERs, is the index number in data table. ;;; for SMALL-FLONUMs, is currently not used. ;;; ;;; for sequence'd data, is an array to hold ;;; (1) the Q's of a VECTOR, or ;;; (2) the characters and/or bits of a string. ;;; for CHARACTERs, is the ASCII value ;;; for CONSTANTs and SMALL-FLONUMs, is the value of the NEWdtp directly, (defvst NEWdtp type size datum) (setq sim:NEWdtp-marker (car (get 'NEWdtp 'STRUCT=INFO))) (setq sim:NILfun-marker (car (get 'NILfun 'STRUCT=INFO))) (eval-when (eval) (alloc '(LIST (50000. 66000. .2) SYMBOL (5000. 10000. 512.) FIXNUM (5000. 12000. .2) HUNK4 (1024. 2048. 512.) HUNK8 (512. 1024. 32.) )) '(comment ALLOC)) (comment MACLISP macros) ;Now some early-needed macros, which may be useful in the object world too. (eval-when (compile) (setq DEFMACRO-FOR-COMPILING 'T DEFMACRO-CHECK-ARGS 'T)) (defmacro prog-return-marker () 'sim:unique) (defmacro sim:bits-per-character () `',*:bits-per-character) (defmacro sim:characters-per-word () `',(// 36. *:bits-per-character)) (defmacro load-byte (size position word) ;Similar to PDP-10 LDB, but "word" is numbered bitwise with bit 0 ; at the (left) high-order end; so "position" argument is inverted. (cond ((or (fixp (setq size (macroexpand size))) (and (not (atom size)) (eq (car size) 'QUOTE) (fixp (cadr size)) (setq size (cadr size)))) (let ((byte-displ (gensym))) `(LET ((,BYTE-DISPL (+ ,size ,position))) (BOOLE 1 ,(lsh -1 (- size 36.)) ;byte mask (ROT ,word ,BYTE-DISPL))))) ;displacement ((let ((byte-displ (gensym)) (byte-len (gensym))) `(LET* ((,BYTE-LEN ,size) (,BYTE-DISPL (+ ,BYTE-LEN ,position))) `(BOOLE 1 (LSH -1 (- 36. ,BYTE-LEN)) ;byte mask (ROT ,word ,BYTE-DISPL)))))) ;displacement ) (defmacro deposit-byte (size position word val) (cond ((or (fixp (setq size (macroexpand size))) (and (not (atom size)) (eq (car size) 'QUOTE) (fixp (cadr size)) (setq size (cadr size)))) (let ((byte-displ (gensym)) (byte-mask (lsh -1 (- size 36.)))) `(LET ((,BYTE-DISPL (- ,(- 36. size) ,position))) (BOOLE 7 (BOOLE 4 ,word (LSH ,BYTE-MASK ,BYTE-DISPL)) (LSH (BOOLE 1 ,val ,BYTE-MASK) ,BYTE-DISPL))))) ((let ((byte-displ (gensym)) (byte-mask (gensym))) `(LET* ((,BYTE-DISPL ,size) (,BYTE-MASK (LSH -1 (- ,BYTE-DISPL 36.)))) (SETQ BYTE-DISPL (- 36. ,BYTE-DISPL ,position)) (BOOLE 7 (BOOLE 4 ,word (LSH ,BYTE-MASK ,BYTE-DISPL)) (LSH (BOOLE 1 ,val ,BYTE-MASK) ,BYTE-DISPL)))))) ) (defmacro typecaseq (item . clauses) `(CASEQ (PTR-TYPEP ,item) . ,clauses)) (defmacro *:funcall-n (n fun &rest args) `(APPLY ,fun (LIST* ,@args (VREF SIM:FUNCALL-N-LISTS ,n)))) (defmacro *:class-of (x) `(ARRAYCALL T (NEWdtp-datum ,x) 0)) (defmacro *:set-class-of (ob val) `(STORE (ARRAYCALL T (NEWdtp-datum ,ob) 0) ,val)) (defmacro si:prinsymbol (slashflag &REST x) `(,(cond (slashflag 'PRIN1) ('PRINC)) ,. x)) (defmacro si:prinnumber (&REST x) `(PRIN1 ,. x)) (defmacro si:special-formp (x) `(GET ,x 'SI:SPECIAL-FORMP)) (defmacro pairp (x) `(EQ (TYPEP ,x) 'LIST)) (defmacro *:make-extend (n data) `(sim:NEWdtp-instance 'EXTEND ,n ,data )) (defmacro make-vector (n) `(sim:NEWdtp-instance 'VECTOR ,n '( () ) )) (defmacro vref (vec i) (cond ((and (|no-funp/|| vec) (|no-funp/|| i)) `(ARRAYCALL T (NEWdtp-datum ,vec) (COND ((EQ (NEWdtp-type ,vec) 'EXTEND) (1+ ,i)) (,i)))) (`((LAMBDA (VEC I) (ARRAYCALL T (NEWdtp-datum VEC) (COND ((EQ (NEWdtp-type VEC) 'EXTEND) (1+ I)) (I)))) ,vec ,i)))) (defmacro vset (vec i val) (cond ((and (|no-funp/|| vec) (|no-funp/|| i)) `(STORE (ARRAYCALL T (NEWdtp-datum ,vec) (COND ((EQ (NEWdtp-type ,vec) 'EXTEND) (1+ ,i)) (,i))) ,val)) (`((LAMBDA (VEC I VAL) (STORE (ARRAYCALL T (NEWdtp-datum VEC) (COND ((EQ (NEWdtp-type VEC) 'EXTEND) (1+ I)) ('T I))) VAL)) ,vec ,i ,val)))) (defmacro make-string (n) `(sim:NEWdtp-instance 'STRING (* (sim:bits-per-character) ,n) () ) ) (defmacro set-string-length (str n) `(SETVST (NEWdtp-SIZE ,str) (* ,n (sim:bits-per-character)))) (defmacro *:fixnum-to-character (n) `(ARRAYCALL T SIM:CHAROB-TABLE ,n)) (defmacro char (string i) (cond ((|no-funp/|| i) `(*:FIXNUM-TO-CHARACTER (LOAD-BYTE (SIM:BITS-PER-CHARACTER) (* (\ ,i (SIM:CHARACTERS-PER-WORD)) (SIM:BITS-PER-CHARACTER)) (ARRAYCALL FIXNUM (NEWdtp-DATUM ,string) (// ,i (SIM:CHARACTERS-PER-WORD))) ))) (`((LAMBDA (STRING INDEX) (*:FIXNUM-TO-CHARACTER (LOAD-BYTE (SIM:BITS-PER-CHARACTER) (* (\ INDEX (SIM:CHARACTERS-PER-WORD)) (SIM:BITS-PER-CHARACTER)) (ARRAYCALL FIXNUM (NEWdtp-DATUM STRING) (// INDEX (SIM:CHARACTERS-PER-WORD))) ))) ,string ,i)))) (defmacro rplachar (str i char) (cond ((and (|no-funp/|| str) (|no-funp/|| i)) `(STORE (ARRAYCALL FIXNUM (NEWdtp-DATUM ,str) (// ,i (SIM:CHARACTERS-PER-WORD))) (DEPOSIT-BYTE (SIM:BITS-PER-CHARACTER) (* (\ ,i (SIM:CHARACTERS-PER-WORD)) (SIM:BITS-PER-CHARACTER)) (ARRAYCALL FIXNUM (NEWdtp-DATUM ,str) (// ,i (SIM:CHARACTERS-PER-WORD))) (*:CHARACTER-TO-FIXNUM ,char)))) (`((LAMBDA (STRING INDEX CHAR) (STORE (ARRAYCALL FIXNUM (NEWdtp-DATUM STRING) (// INDEX (SIM:CHARACTERS-PER-WORD))) (DEPOSIT-BYTE (SIM:BITS-PER-CHARACTER) (* (\ INDEX (SIM:CHARACTERS-PER-WORD)) (SIM:BITS-PER-CHARACTER)) (ARRAYCALL FIXNUM (NEWdtp-DATUM STRING) (// INDEX (SIM:CHARACTERS-PER-WORD))) (*:CHARACTER-TO-FIXNUM CHAR)))) ,str ,i ,char)))) (defmacro bit (seq1 i) (cond ((|no-funp/|| i) `(LOAD-BYTE 1 (\ ,i 36.) (ARRAYCALL FIXNUM (NEWdtp-DATUM ,seq1) (// ,i 36.)))) (`((LAMBDA (SEQ1 INDEX) (LOAD-BYTE 1 (\ INDEX 36.) (ARRAYCALL FIXNUM (NEWdtp-DATUM SEQ1) (// INDEX 36.)))) ,seq1 ,i)))) (defmacro rplacbit (seq1 i bit) (cond ((and (|no-funp/|| seq1) (|no-funp/|| i)) `(STORE (ARRAYCALL FIXNUM (NEWdtp-DATUM ,seq1) (// ,i 36.)) (DEPOSIT-BYTE 1 (\ ,i 36.) (ARRAYCALL FIXNUM (NEWdtp-DATUM ,seq1) (// ,i 36.)) ,bit))) (`((LAMBDA (SEQ1 INDEX BIT) (STORE (ARRAYCALL FIXNUM (NEWdtp-DATUM SEQ1) (// INDEX 36.)) (DEPOSIT-BYTE 1 (\ INDEX 36.) (ARRAYCALL FIXNUM (NEWdtp-DATUM SEQ1) (// INDEX 36.)) BIT))) ,seq1 ,i ,bit)))) ;;; Checks for no functions calls in a form so that ;;; "(MUMBLE ,x ,x)" may be used instead of ;;; "((LAMBDA (OB) (MUMBLE OB OB)) ,x)" (defun |no-funp/|| (x) (cond ((or (atom x) (memq (car x) '(QUOTE FUNCTION DECLARE)))) ((not (atom (car x))) () ) ((|carcdrp/|| (car x)) (|no-funp/|| (cadr x))) )) (defun |carcdrp/|| (x) (and (symbolp x) (let ( (n (flatc x)) ) (declare (fixnum n)) (cond ((or (not (lessp 2 n 7)) (not (eq (getchar x 1) 'C)) (not (eq (getchar x n) 'R))) () ) ((prog (tmp) A (and (< (setq n (1- n)) 2) (return 'T)) (setq tmp (getchar x n)) (and (not (memq tmp '(A D))) (return () )) (go a))))))) (eval-when (compile) (setq DEFMACRO-FOR-COMPILING () DEFMACRO-CHECK-ARGS () )) (comment INITs etc) (defun sim:NEWdtp-instance (type size-or-index frob) (let ((datum (cons-a-NEWdtp TYPE type SIZE size-or-index DATUM (cond ((memq type '(CHARACTER CONSTANT SMALL-FLONUM)) (cond ((null frob) (car (error-1 '|"frob" is null for INOB| 'sim:NEWdtp-instance frob))) (frob))) ((caseq type ((STRING BITS) (cond ((eq (typep frob) 'ARRAY) frob) (frob (error-1 '|"frob" for STRING/BITS| 'sim:NEWdtp-instance frob)) ((array () FIXNUM (1+ (// size-or-index (cond ((eq type 'STRING) 35.) ('T 36.)))))))) ((VECTOR EXTEND) (cond ((eq (typep frob) 'ARRAY) frob) ((or (null frob) (not (atom frob))) (setq datum (array () T size-or-index)) (and frob (fillarray datum frob)) datum) ('T (error-1 '|"frob" for VECTOR| 'sim:NEWdtp-instance frob)))) (T (error-1 '|Wrong "type"| 'sim:NEWdtp-instance type)))))))) (and (memq type '(CONSTANT CHARACTER)) (store (arraycall T (caseq type (CONSTANT sim:constant-table) (CHARACTER sim:charob-table)) size-or-index) datum)) datum)) (defun sim:nil-reset () (setq sim:load-stream () sim:error-stream () sim:putback-al () sim:baktrace-info () sim:traced-functions () sim:progs () sim:special-decls-l () sim:blintz () ;BLINTZ should be an array sim:errsetp () sim:eprintp 'T ) (setq sim:lexical-cln 0 sim:cln 0 sim:trace-level 0 ) (mapatoms '(lambda (sym) (remprop sym 'SPECIAL-blintz-index) (remprop sym 'LOCAL-blintz-index))) (sstatus ttyint 5 'sim:int-char-service) (sstatus ttyint 6 'sim:int-char-service) (setq sim:charob-table (array () T (^ 2 *:bits-per-character)) sim:constant-table (array () T 10.)) (setq sim:variable-buffer () sim:value-buffer () ) ;Fill in the character-object table (do i 0 (1+ i) (> i 127.) (sim:NEWdtp-instance 'CHARACTER i i)) ;^C is End-Of-File character ?? (setq *:eof-character (arraycall T sim:charob-table 3)) (setq sim:unique (list () )) ;Set up initial CONSTANTs (setq *:nullity (sim:NEWdtp-instance 'CONSTANT 0 '|()|) *:truthity (sim:NEWdtp-instance 'CONSTANT 1 '|#T|) *:unbound-v (sim:NEWdtp-instance 'CONSTANT 2 '|#!UNBOUND-VALUE!|) *:unbound-f (sim:NEWdtp-instance 'CONSTANT 3 '|#!UNBOUND-VALUE!|) *:noclass (sim:NEWdtp-instance 'CONSTANT 4 '|#!NOCLASS!|)) (setq *:ptr-class-class *:noclass *:ptr-class-object *:noclass) (setq *:ptr-class-class (sim:make-class 'CLASS *:ptr-class-object)) (setq *:ptr-class-object (sim:make-class 'OBJECT *:ptr-class-object)) ;First self-loop, class==>class (*:set-class-of *:ptr-class-class *:ptr-class-class) ;Second self-loop, object<class (*:set-class-of *:ptr-class-object *:ptr-class-class) (setq *:known-classes `((OBJECT ,*:ptr-class-object *:PTR-CLASS-OBJECT))) (setq *:ptr-class-number (sim:make-class 'NUMBER *:ptr-class-object)) (mapc '(lambda (type name numberp) (set name (sim:make-class type (cond (numberp *:ptr-class-number) (*:ptr-class-object)))) (push (list type (eval name) name) *:known-classes)) '(BIGNUM BIGFLOAT COMPLEX STREAM CLOSURE BUFFERKEY) '(*:ptr-class-bignum *:ptr-class-bigfloat *:ptr-class-complex *:ptr-class-stream *:ptr-class-closure *:ptr-class-bufferkey ) '(T T T () () () )) ;Infinite (circular) lists of NILs and UNBOUNDs (rplacd (setq sim:NIL* (list () )) sim:NIL*) (rplacd (setq sim:UNBOUND* (list *:unbound-v )) sim:UNBOUND*) *:truthity ) (defun sim:make-class (type-name superior) ;Make a class object, with symbolic type name, and having one superior. (*:make-extend *:class-size `(,*:ptr-class-class ,type-name (,superior) () ))) (defun sim:int-char-service (file char) (cond ((= char 5) (MACLISP-TOPLEVEL)) ((= char 6) (NIL-TOPLEVEL)) ('T (error-1 '|What are you doing| 'sim:int-char-service char)))) ;;; Load-time loop to add NIL FUNCTION-CELLs for MACLISP routines ;;; NOTE WELL! the call to "cons-a-NILfun" must be macro-expanded (prog (*rset name subr args) (setq SI:SPECIAL-FORM-FUNS (make-vector 50.) SIM:SFFS-CNT 0) ;Certain FSUBRs, that don't really involve calling "eval" (mapc '(lambda (atom) (cond ((and (eq (sysp atom) 'FSUBR) (not (get atom 'FUNCTION-CELL)) (not (get atom 'SI:SPECIAL-FORMP))) (setq name (implode (nconc (explodec atom) '(/[ M A C L I S P /- S U B R /])))) (putprop name (get atom 'FSUBR) 'SUBR) (vset SI:SPECIAL-FORM-FUNS (setq SIM:SFFS-CNT (1+ SIM:SFFS-CNT)) name) (putprop atom sim:sffs-cnt 'SI:SPECIAL-FORMP) ))) '(FASLOAD UAPPEND UCLOSE UFILE UPROBE UREAD UWRITE BREAK COMMENT EDIT DECLARE DEFPROP FUNCTION QUOTE POP STATUS SSTATUS)) ;All SUBRs and LSUBRs are initially "linked". (mapatoms '(lambda (atom) (cond ((and (memq (sysp atom) '(SUBR LSUBR)) ;Dont redefine (not (get atom 'FUNCTION-CELL))) ; existing NIL subrs (cond ((setq subr (getl atom '(SUBR LSUBR)) args (args atom))) ((eq (car subr) 'SUBR) (setq args '(() . 1))) (T (setq args '(0 . 777)))) (putprop atom (cons-a-NILfun TYPE 'subr ARGS args BODY (cons atom (cadr subr))) 'FUNCTION-CELL))))) (cond ((or (not (boundp 'sim:nil-reset)) (null sim:nil-reset)) (setq sim:nil-reset (sim:nil-reset)))) (return '(comment MAPATOMS and SIM:NIL-RESET))) (comment NIL-DEFUN macro) ;;; Causes a FUNCTION-CELL to appear on the symbol and generates ;;; a MacLISP function, which can be compiled, for the code. (defmacro NIL-DEFUN (name &REST bvl-body &AUX kind bvl body spc-decls more-defs name-alias) (setq kind (car (memq (car bvl-body) '(SF-SUBR EXPR MACRO NIL-EXPR EXPR-EXPR MACRO-MACRO)))) (cond (kind (pop bvl-body)) ('T (setq kind 'EXPR))) (desetq (bvl . body) bvl-body) (cond ((eq kind 'SF-SUBR) (setq name-alias (implode (nconc (explodec name) '(/[ M A C L I S P /- S U B R /])))) `(PROGN 'COMPILE (NIL-DEFUN ,name-alias ,@bvl-body) (VSET SI:SPECIAL-FORM-FUNS (SETQ SIM:SFFS-CNT (1+ SIM:SFFS-CNT)) ',name-alias) (PUTPROP ',name SIM:SFFS-CNT 'SI:SPECIAL-FORMP))) ((eq kind 'NIL-EXPR) (let* ((nil-name (implode (append '(N I L /-) (explodec name)))) (maclisp-name (implode (append '(M A C L I S P /- ) (explodec name))) ) (subr (getl name '(SUBR LSUBR))) (args (args name)) (subr-form `(GET ',name ',(car subr)))) ;What is this for, jonl?? (cond ((eq (car subr) 'SUBR) (setq args '(() . 1))) ('T (setq args '(0 . 1)))) `(PROGN 'COMPILE (PUTPROP ',maclisp-name ,subr-form ',(car subr)) (PUTPROP ',maclisp-name (cons-a-NILfun TYPE 'SUBR ARGS ',args BODY (CONS ',maclisp-name ,subr-form)) 'FUNCTION-CELL) (PUTPROP ',name (cons-a-NILfun TYPE 'EXPR ARGS ',bvl ;??? BODY ',nil-name) 'FUNCTION-CELL) (NIL-DEFUN ,nil-name EXPR-EXPR ,@bvl-body)))) ('T (setq spc-decls (mapcan '(lambda (x) (cond ((atom x) (and (not (memq x '(&OPTIONAL &REST &AUX))) (list x))) ((list (car x))))) bvl)) (and spc-decls (setq body (cond ((and (not (atom (car body))) (eq (caar body) 'DECLARE)) `((DECLARE (SPECIAL ,@spc-decls) ,@(cdar body)) ,@(cdr body))) (`((DECLARE (SPECIAL ,@spc-decls)) ,@body))))) (cond ((memq kind '(MACRO MACRO-MACRO)) (and (eq kind 'MACRO-MACRO) (setq more-defs `((DEFUN (,name MACRO) ,bvl . ,body)))) (setq kind 'MACRO)) ((eq kind 'EXPR-EXPR) ;Defining both in MacLISP and NIL? (setq name-alias (implode (nconc (explodec name) '(/[ M A C L I S P /- S U B R /]))) kind (cond ((memq compiler-state '(MAKLAP DECLARE COMPILE)) '(NIL-SUBR . SUBR)) ('(NIL-EXPR . EXPR)))) (setq more-defs `((DECLARE (*EXPR ,name-alias)) (DEFUN ,name ,bvl ,@(and spc-decls `((DECLARE (SPECIAL ,@spc-decls)))) (,name-alias)) (PUTPROP ',name-alias (GET ',name ',(car kind)) ',(cdr kind)))) (setq kind 'EXPR))) ;"kind" is either EXPR or MACRO, "more-defs" in case of EXPR-EXPR `(PROGN 'COMPILE (PUTPROP ',name (cons-a-NILfun TYPE ',kind ARGS ',bvl BODY ',name) 'FUNCTION-CELL) (DEFUN (,name NIL-EXPR NIL-SUBR) () . ,body) ,@more-defs ',name)))) (comment MACMAC-DEFUN and *:functions) ;;; *:TOTAL-SIZE, *:SET-TOTAL-SIZE, *:OBJECT-SIZE, ;;; *:CHARACTER-TO-FIXNUM, *:FIXNUM-TO-CHARACTER, ;;; *:CHARACTER-TO-DIGIT-VALUE, ;;; PTR-TYPEP, SUBRP, FIXNUMP, FLONUMP, SMALL-FLONUMP, ;;; CHARACTERP, STRINGP, BITSP ;;; TYPEP, LISTP, NNLISTP, VECTORP, SEQUENCEP, ;;; LIST-LENGTH, VECTOR-LENGTH, BITS-LENGTH, STRING-LENGTH ;;; For defining a NIL data-type predicate, ;;; with incarnation in maclisp as a macro, and ;;; with incarnation in NIL as 1-argument function over that macro. (defmacro MACMAC-DEFUN (nil-name &REST bvl-body &AUX mac-name) (setq mac-name (cond ((atom nil-name) nil-name) ((prog2 () (cadr nil-name) (setq nil-name (car nil-name)))))) `(PROGN 'COMPILE (DEFUN (,mac-name MACRO) . ,bvl-body) (NIL-DEFUN ,nil-name (SIM:ARG1) (,mac-name SIM:ARG1)))) (macmac-defun *:TOTAL-SIZE (x) `(NEWdtp-SIZE ,(cadr x))) ;;; Must only decrease the size of a sequence!! (macmac-defun *:SET-TOTAL-SIZE (x) `(SETVST (NEWdtp-SIZE ,(cadr x)) ,(caddr x))) (macmac-defun *:OBJECT-SIZE (x) `(CASEQ (NEWdtp-TYPE ,(cadr x)) (STRING *:bits-per-character) (BITS 1) ((VECTOR EXTEND) 18.) (T 0))) (macmac-defun *:CHARACTER-TO-FIXNUM (x) `(NEWdtp-DATUM ,(cadr x))) (macmac-defun *:FIXNUM-TO-CHARACTER (x) `(ARRAYCALL T SIM:CHAROB-TABLE ,(cadr x))) ;;; Takes either kind of Fixed-point - FIXNUM or BIGNUM - and floats ;;; it into whichever kind of Floating-point is necessary to hold the ;;; exponent field. (macmac-defun *:FIX-TO-FLOAT (x) `(MACLISP-FLOAT ,(cadr x))) ;;; Returns a number from 0 thru 36, or -1 (macmac-defun *:CHARACTER-TO-DIGIT-VALUE (char) `((LAMBDA (FIXVAL) (DECLARE (FIXNUM FIXVAL)) (COND ((LESSP 47. FIXVAL 58.) (- FIXVAL 48.)) ;A base-10 digit ((LESSP 64. FIXVAL 91.) (- FIXVAL 55.)))) ;A "letter" digit (*:CHARACTER-TO-FIXNUM ,char))) (comment PTR-TYPEP and macroified type predicates) (macmac-defun PTR-TYPEP (x) `((LAMBDA (OB) (COND ((NULL OB) 'CONSTANT) ((NOT (HUNKP OB)) (COND ((EQ (SETQ OB (TYPEP OB)) 'LIST) 'PAIR) (OB))) ((NOT (EQ (CDR OB) sim:NEWdtp-marker)) 'HUNK) ((NEWdtp-TYPE OB)))) ,(cadr x))) ;;; REMEMBER! only a live in a function cell. For the simulator, ;;; disembodied function cells do float around. (macmac-defun SUBRP (x) `((LAMBDA (OB) (AND (HUNKP OB) (EQ (CDR OB) SIM:NILFUN-MARKER) *:TRUTHITY)) ,(cadr x))) (macmac-defun *:FSYMEVAL-SUBR (x) `(GET ,(cadr x) 'FUNCTION-CELL)) (macmac-defun ONEP (x) (cond ((|no-funp/|| (cadr x)) `(AND (FIXNUMP ,(cadr x)) (= ,(cadr x) 1) *:TRUTHITY)) (`((LAMBDA (OB) (AND (FIXNUMP OB) (= OB 1) *:TRUTHITY)) ,(cadr x))))) (defmacro gen-datapredicate-macro l `(PROGN 'COMPILE ,@(mapcar '(lambda (name) `(MACMAC-DEFUN ,(implode (append (explodec name) '(P))) (x) `(AND (EQ (PTR-TYPEP ,(cadr x)) ',',name) *:TRUTHITY))) l))) (gen-datapredicate-macro FIXNUM FLONUM SMALL-FLONUM CHARACTER STRING BITS EXTEND) (macmac-defun LISTP (x) `((LAMBDA (OB) (OR (NULL OB) (PAIRP OB))) ,(cadr x))) (macmac-defun NNLISTP (x) `(PAIRP ,(cadr x))) (macmac-defun VECTORP (x) `(AND (MEMQ (PTR-TYPEP ,(cadr x)) '(VECTOR EXTEND)) *:TRUTHITY)) (macmac-defun SEQUENCEP (x) `((LAMBDA (OB) (COND ((AND (HUNKP OB) (EQ (CDR OB) sim:NEWdtp-marker) (MEMQ (NEWdtp-TYPE OB) '(VECTOR STRING BITS))) *:TRUTHITY) ((LISTP OB)))) ,(cadr x))) (comment sequence LENGTH funs) (macmac-defun LIST-LENGTH (x) `(LENGTH ,(cadr x))) (macmac-defun VECTOR-LENGTH (x) `((LAMBDA (OB) (OR (VECTORP OB) (ERROR-1 'WTA 'VECTOR-LENGTH OB)) (NEWdtp-SIZE OB)) ,(cadr x))) (macmac-defun BITS-LENGTH (x) `((LAMBDA (OB) (OR (BITSP OB) (ERROR-1 'WTA 'BITS-LENGTH OB)) (NEWdtp-SIZE OB)) ,(cadr x))) (macmac-defun STRING-LENGTH (x) `((LAMBDA (OB) (OR (STRINGP OB) (ERROR-1 'WTA 'STRING-LENGTH OB)) (// (NEWdtp-SIZE OB) *:BITS-PER-CHARACTER)) ,(cadr x))) (macmac-defun CLASS-OF (x) `((LAMBDA (OB) (AND (EXTENDP OB) (*:CLASS-OF OB))) ,(cadr x))) (comment NIL-EVAL etc.) (nil-defun EVAL nil-expr (sim:form-to-eval) (declare (special sim:baktrace-info sim:trace-level)) (typecaseq sim:form-to-eval ((CONSTANT CHARACTER VECTOR STRING BITS FIXNUM FLONUM SMALL-FLONUM) sim:form-to-eval) (SYMBOL (prog (lcbi scbi lb-cln sb-cln sim:symeval) ; Local-Cellcluster-Blintz-Index, and Special-... ; Local-Binding-Level-Number and Special-... (and (or (not (boundp sim:form-to-eval)) (eq (setq sim:symeval (symeval sim:form-to-eval)) *:unbound-v)) (error-1 '|Unbound variable| 'EVAL sim:form-to-eval)) (cond ((or (null (setq lcbi (sim:get-blintz-index sim:form-to-eval () () ))) (zerop (setq lb-cln (or (cadr (assq lcbi sim:blintz)) 0)))) 'SPECIAL) ((or (null (setq sci (sim:get-blintz-index sim:form-to-eval 'T () ))) (zerop (setq sb-cln (or (cadr (assq lcbi sim:blintz)) 0)))) 'LOCAL) ;Drats! two different kinds of bindings extant! ((> sb-cln lb-cln) 'SPECIAL) ((not (< lb-cln sim:lexical-cln)) 'LOCAL) ((error-1 '|Free variable can't cross local bindings (in simulator)| 'EVAL sim:form-to-eval))) (return (symeval sim:form-to-eval)) )) ((PAIR EXTEND) (let ((sim:baktrace-info sim:baktrace-info) (sim:trace-level sim:trace-level) (sim:cln sim:cln) (sim:lexical-cln sim:lexical-cln)) (prog (sim:type sim:funcell sim:list-of-args sim:tracedp) (cond ((extendp sim:form-to-eval) (and (numberp sim:form-to-eval) (return sim:form-to-eval)) (error-1 '|EXTENDed data not yet EVAL'able| 'EVAL sim:form-to-eval)) ((symbolp (car sim:form-to-eval)) (setq sim:funcell (SI:SPECIAL-FORMP (car sim:form-to-eval))) (cond (sim:funcell (and *rset (push (list 'EVAL (length sim:baktrace-info) sim:form-to-eval 0) sim:baktrace-info)) (setq sim:funcell (vref SI:SPECIAL-FORM-FUNS sim:funcell) sim:list-of-args (list (cdr sim:form-to-eval))) (go XIT)) ((null (setq sim:funcell (get (CAR sim:form-to-eval) 'FUNCTION-CELL))) (error-1 'LOF 'EVAL (car sim:form-to-eval)))) (cond ((eq (NILfun-type sim:funcell) 'MACRO) (setq sim:list-of-args (sim:spread-and-apply (NILfun-args sim:funcell) (list sim:form-to-eval) (NILfun-body sim:funcell))) (return (nil-eval sim:list-of-args)))) (setq sim:cln (1+ sim:cln) sim:lexical-cln sim:cln)) ((pairp (car sim:form-to-eval)) (and (not (eq (caar sim:form-to-eval) 'LAMBDA)) (go BADF)) (setq sim:funcell (car sim:form-to-eval))) ('T (go BADF))) (and *rset (push (list 'EVAL (length sim:baktrace-info) sim:form-to-eval 0) sim:baktrace-info)) (setq sim:list-of-args (mapcar 'nil-eval (cdr sim:form-to-eval))) XIT (cond ((and (symbolp (car sim:form-to-eval)) (get (car sim:form-to-eval) 'NIL-TRACED)) (sim:cr+tab-to (setq sim:trace-level (1+ sim:trace-level)) sim:error-stream) (oustr '" Entering " sim:error-stream) (prin1 (car sim:form-to-eval) sim:error-stream) (ouch '~/ sim:error-stream) (nil-prin1 sim:list-of-args sim:error-stream) (setq sim:tracedp 'T))) (setq sim:list-of-args (nil-apply sim:funcell sim:list-of-args)) (cond (sim:tracedp (sim:cr+tab-to sim:trace-level sim:error-stream) (oustr '" Exiting " sim:error-stream) (prin1 (car sim:form-to-eval) sim:error-stream) (ouch '~/ sim:error-stream) (nil-prin1 sim:list-of-args sim:error-stream))) (return sim:list-of-args) BADF (error-1 '|Unevaluable datum| 'EVAL sim:form-to-eval)))))) (defun sim:get-blintz-index (sym specialp function-cell-p) (cond (function-cell-p (error-1 '|No BLINTZ numbers for function-cells in simulator| 'sim:get-blintz-index sym)) ((get sym (cond (specialp 'SPECIAL-blintz-index) ('T 'LOCAL-blintz-index)))))) ;;; Apply a function to a list of arguments ;;; "function" must be either a symbol, or a lambda-expression, ;;; or a NIL function-cell (nil-defun APPLY nil-expr (sim:fun sim:arglist) (let (sim:funcell) (cond ((symbolp sim:fun) ;Allow case of "(NIL-APPLY 'EQ FOO)" (cond ((SI:SPECIAL-FORMP sim:fun) (error-1 '|Special forms not applicable| 'APPLY sim:fun)) ((null (setq sim:funcell (*:fsymeval-subr sim:fun))) (error-1 'LOF 'APPLY sim:fun)) ((nil-apply sim:funcell sim:arglist)))) ((not (subrp sim:fun)) (cond ((and (pairp sim:fun) (eq (car sim:fun) 'LAMBDA)) ;For maclisp compatibility, allow a quoted lambda (sim:spread-and-apply (cadr sim:fun) sim:arglist (cddr sim:fun))) ('T (error-1 'LOF 'APPLY sim:fun)))) ((let ((sim:funbody (NILfun-body sim:fun)) (sim:argform (NILfun-args sim:fun))) (caseq (NILfun-type sim:fun) (EXPR (sim:spread-and-apply sim:argform sim:arglist sim:funbody)) (SUBR (*:apply-subr sim:fun sim:arglist)) (MACRO (error-1 '|Macros not applicable| 'APPLY sim:fun)) (T (error-1 'LOF 'APPLY sim:fun)))))))) (nil-defun FUNCALL nil-expr (sim:arg1 &REST sim:RESTV) (nil-apply sim:arg1 sim:RESTV)) ;;; The following macro is used only by *:APPLY-SUBR. (defmacro FAST-SUBRAPPLY-MACRO (call-fun select-fun the-length clause-count the-subr the-arglist) `(caseq ,the-length ,@(do ((args () `(,@args ,(cond ((eq select-fun 'NTH) `(,select-fun ,i ,the-arglist)) ('T `(,select-fun ,the-arglist ,i))))) (clauses () `(,@clauses (,i (,call-fun 'T ,the-subr ,@args)))) (i 0 (1+ i))) ((= i clause-count) clauses)))) (nil-defun *:APPLY-SUBR expr-expr (sim:fun sim:arglist) (let ((sim:subr-ptr (cdr (NILfun-body sim:fun))) (sim:argform (NILfun-args sim:fun)) sim:len) (cond ((listp sim:arglist) (setq sim:len (length sim:arglist)) (cond ((null (car sim:argform)) (and (not (= (cdr sim:argform) sim:len)) (error-1 'WNA 'APPLY (cons sim:fun sim:arglist))) (fast-subrapply-macro subrcall nth sim:len 5 sim:subr-ptr sim:arglist)) ('T (and (or (< sim:len (car sim:argform)) (> sim:len (cdr sim:argform))) (error-1 'WNA 'APPLY (cons sim:fun sim:arglist))) (fast-subrapply-macro lsubrcall nth sim:len 5 sim:subr-ptr sim:arglist)))) ((vectorp sim:arglist) (setq sim:len (vector-length sim:arglist)) (cond ((null (car sim:argform)) (and (not (= (cdr sim:argform) sim:len)) (error-1 'WNA 'APPLY (cons sim:fun sim:arglist))) (fast-subrapply-macro subrcall vref sim:len 5 sim:subr-ptr sim:arglist)) ('T (and (or (< sim:len (car sim:argform)) (> sim:len (cdr sim:argform))) (error-1 'WNA 'APPLY (cons sim:fun sim:arglist))) (fast-subrapply-macro lsubrcall vref sim:len 5 sim:subr-ptr sim:arglist)))) ('T (error-1 'WTA 'APPLY sim:arglist))))) ;;; SIM:SPREAD-AND-APPLY ;;; Takes a bound-variable-list (a "lambda-list") as first arg, ;;; a list of arguments as second arg, ;;; a symbol, or list for progn-evaluation, as third arg, the "body" of ;;; the function. ;;; Loops over all variables doing the appropriate ;;; settings after binding all variables in the lambda-list to UNBOUND ;;; Then does the progn-evaluation (or applies the symbol) ;;; SIM:UPDATE-BLINTZ ;;; Takes a bound-variable-list (or vector) as first arg, ;;; a symbol, or list for progn-evaluation, as second arg, ;;; a function name (such as PROG, DO, or APPLY) as third arg ;;; Updates values of SIM:BLINTZ, SIM:SPECIAL-DECLS-L and SIM:CLN (defun sim:update-blintz (seq body fun) (cond ((atom body)) ('T (setq sim:cln (1+ sim:cln)) (and (pairp (car body)) (eq (caar body) 'DECLARE) (do ((tem (assq 'SPECIAL (cdar body)) (assq 'SPECIAL (cdr (memq tem (cdar body)))))) ((null tem)) (push (cons sim:cln (cdr tem)) sim:special-decls-l))) (do ((bvl (if (vectorp seq) () seq) (cdr bvl)) (i 0 (1+ i)) (len (nil-length seq)) (vecp (vectorp seq)) var) ((if vecp (>= i len) bvl)) (setq var (if vecp (car bvl) (vref seq i))) (cond ((not (symbolp var)) (error-1 'ITM fun seq)) ((or (get var 'SPECIAL) (do ((l sim:special-decls-l (cdr l))) ((or (null l) (< (caar l) sim:lexical-cln))) (and (memq var (car l)) (return 'T)))) (push (list (or (get var 'SPECIAL-blintz-index) (putprop var (maknam (append '(S P E C I A L /[) (explodec var) '(/]))) 'SPECIAL-blintz-index)) sim:cln var) sim:blintz)) ((push (list (or (get var 'LOCAL-blintz-index) (putprop var (maknam (append '(L O C A L /[) (explodec var) '(/]))) 'LOCAL-blintz-index)) sim:cln var) sim:blintz))))))) (defun sim:spread-and-apply (sim:lambdalist sim:args sim:funbody) (funcall* (do ((bvl sim:lambdalist (cdr bvl)) (mode ()) (n 0)) ((atom sim:lambdalist) (cond ((null sim:lambdalist)) ((error-1 'ILL 'APPLY sim:lambdalist))) n) (cond ((memq x '(&OPTIONAL &AUX)) (setq mode x)) ((eq x '&REST) (setq mode ())) ((symbolp x) (setq n (1+ n))) ((pairp x) (sim:decompose (function (lambda (var ignore) (setq n (1+ n)))) (car x) () )) ;slight waste ((error-1 'ILL 'APPLY sim:lambdalist)))) (function sim:s&a-1) sim:lambdalist sim:args sim:funbody)) (defun SIM:S&A-1 (sim:lambdalist sim:args sim:funbody &REST sim:vals) (*funcall (nil-length sim:vals) (function sim:s&a-2) sim:lambdalist sim:args sim:funbody sim:vals)) ;; Push variable name and tentative value onto sim:vars, sim:vals. ;; This macro is used only by SIM:S&A-2. (defmacro SIM:S&A-PUSH (sym) (if (symbolp sym) `(PROGN (VSET SIM:VARS SIM:N ,sym) (VSET SIM:VALS SIM:N (IF (BOUNDP ,sym) (SYMEVAL ,sym) *:UNBOUND-V)) (SETQ SIM:N (1+ SIM:N))) `(LET ((SIM:VAR ,sym)) (VSET SIM:VARS SIM:N SIM:VAR) (VSET SIM:VALS SIM:N (IF (BOUNDP SIM:VAR) (SYMEVAL SIM:VAR) *:UNBOUND-V)) (SETQ SIM:N (1+ SIM:N))))) (defun SIM:S&A-2 (sim:lambdalist sim:args sim:funbody sim:vars &REST sim:vals) ;Compute initial vars and vals for the PROGV. (do ((sim:bvl sim:lambdalist (cdr sim:bvl)) (sim:mode () ) (sim:x) (sim:n 0)) ((atom sim:lambdalist) (cond ((null sim:lambdalist)) ((error-1 'ILL 'APPLY sim:lambdalist))) sim:n) (setq sim:x (car sim:bvl)) (cond ((memq sim:x '(&OPTIONAL &AUX)) (setq sim:mode sim:x)) ((eq sim:x '&REST) (setq sim:mode () )) ((symbolp sim:x) (sim:s&a-push sim:x)) ((pairp sim:x) (if (cddr sim:x) (sim:s&a-push (caddr sim:x))) (sim:decompose (function (lambda (sim:x sim:ignore) (sim:s&a-push sim:x))) (car sim:x) () )) ((error-1 'ILL 'APPLY sim:lambdalist)))) (let ((sim:special-decls-l sim:special-decls-l) (sim:cln sim:cln) (sim:blintz sim:blintz)) (progv #M (sequence-to-list sim:vars) #N sim:vars #M (sequence-to-list sim:vals) #N sim:vals ;The following PROG deposits values into variables. (prog (sim:bvl sim:argl sim:argv sim:i sim:nargs sim:item) (cond ((listp sim:args) (setq sim:argl sim:args sim:argv () sim:nargs (list-length sim:argl))) ((vectorp sim:args) (if (zerop (vector-length sim:args)) (setq sim:argl () sim:argv () sim:nargs 0) (setq sim:argl () sim:argv sim:args sim:nargs (vector-length sim:argv)))) ((error-1 'WTA 'APPLY sim:args))) (setq sim:bvl sim:lambdalist sim:i 0) ;Index into sim:argv; arg count. LOOP ;Process an ordinary argument. (if (atom sim:bvl) (go EXIT)) (pop sim:bvl sim:item) (cond ((eq sim:item '&OPTIONAL) (go OPT-LOOP)) ((eq sim:item '&REST) (go REST)) ((eq sim:item '&AUX) (go AUX-LOOP)) ((>= sim:i sim:nargs) ;Too few args supplied? (error-1 'WNA 'APPLY (list sim:lambdalist sim:args))) ((sim:decompose (function set) sim:item (if sim:argv (vref sim:argv sim:i) (car sim:argl))))) (setq sim:i (1+ sim:i) sim:argl (cdr sim:args)) (go LOOP) OPT-LOOP ;Process an optional argument. (if (atom sim:bvl) (go EXIT)) (pop sim:bvl sim:item) (cond ((eq sim:item '&OPTIONAL) (go ERR)) ((eq sim:item '&REST) (go REST)) ((eq sim:item '&AUX) (go AUX-LOOP)) ((symbolp sim:item) (set sim:item (if (< sim:i sim:nargs) (if sim:argv (vref sim:argv sim:i) (car sim:argl)) () ))) ((or (not (listp sim:item)) (not (listp (cdr sim:item))) (and (cddr sim:item) (or (not (listp (cddr sim:item))) (not (symbolp (caddr sim:item))) (cdddr sim:item)))) (go ERR)) ((< sim:i sim:nargs) (sim:decompose (function set) (car sim:item) (if sim:argv (vref sim:argv sim:i) (car sim:argl))) (if (caddr sim:item) (set (caddr sim:item) #T))) ((sim:decompose (function set) (car sim:item) (nil-eval (cadr sim:item))) (if (caddr sim:item) (set (caddr sim:item) () )))) (setq sim:i (1+ sim:i) sim:argl (cdr sim:args)) (go OPT-LOOP) REST (if (atom sim:bvl) (go ERR)) (pop sim:bvl sim:item) (if sim:item (if (or (not (symbolp sim:item)) (memq sim:item '(&REST &OPTIONAL &AUX))) (go ERR) (set sim:item (cond ((>= sim:i sim:nargs) () ) (sim:argv (vector-subseq sim:argv sim:i)) ((list-to-vector sim:argl)))))) (setq sim:i sim:nargs) ;All gobbled up! (if (atom sim:bvl) (go EXIT)) (pop sim:bvl sim:item) (if (not (eq sim:item '&AUX)) (go ERR)) AUX-LOOP (if (atom sim:bvl) (go EXIT)) (pop sim:bvl sim:item) (cond ((symbolp sim:item) (if (memq sim:item '(&OPTIONAL &REST &AUX)) (go ERR)) (set sim:item () )) ((or (not (listp sim:item)) (not (listp (cdr sim:item))) (cddr sim:item)) (go ERR)) ((sim:decompose (function set) (car sim:item) (nil-eval (cadr sim:item))))) (go AUX-LOOP) ERR (error-1 'ILL 'APPLY sim:lambdalist) EXIT (if (< sim:i sim:nargs) ;Too many args supplied? (error-1 'WNA 'APPLY (list sim:lambdalist sim:args))) ) ;End of the big moby PROG! (sim:update-blintz sim:vars sim:funbody 'APPLY) (cond ((symbolp sim:funbody) (let ((sim:prop (getl sim:funbody '(NIL-EXPR NIL-SUBR)))) (caseq (car sim:prop) (NIL-SUBR (subrcall t (cadr sim:prop))) (NIL-EXPR (funcall (cadr sim:prop) )) (T (error-1 'LOF 'APPLY sim:prop))))) ('T (sim:iprogn sim:funbody))) ))) (comment NIL SF-SUBRs written in MacLISP) (nil-defun AND sf-subr (sim:form-to-eval) (sim:and//or sim:form-to-eval *:truthity)) (nil-defun OR sf-subr (sim:form-to-eval) (sim:and//or sim:form-to-eval () )) (defun sim:and//or (sim:forms-to-eval sim:last-val) (prog (sim:andp) (setq sim:andp sim:last-val) A (and (cond ((null sim:forms-to-eval)) ((not sim:andp) sim:last-val) ((not sim:last-val) 'T)) (return sim:last-val)) (setq sim:last-val (nil-eval (car sim:forms-to-eval))) (pop sim:forms-to-eval) (go A))) (nil-defun COND sf-subr (sim:form-to-eval) (do ((sim:clause sim:form-to-eval (cdr sim:clause)) (sim:pred-result)) ((null sim:clause) () ) (and (setq sim:pred-result (nil-eval (caar sim:clause))) (return (cond ((cdar sim:clause) (sim:iprogn (cdar sim:clause))) (sim:pred-result)))))) (nil-defun CASEQ sf-subr (sim:arg1) (sim:caseq (nil-eval (car sim:arg1)) (cdr sim:arg1))) (defun sim:caseq (sim:last-val sim:clause) (prog (sim:type) (setq sim:type (ptr-typep sim:last-val)) (and (not (memq sim:type '(SYMBOL FIXNUM CHARACTER))) (error-1 'WTA 'CASEQ sim:last-val)) TG (and (null sim:clause) (return () )) (and (cond ((eq (caar sim:clause) 'T)) ((null (caar sim:clause)) () ) ((not (pairp (caar sim:clause))) (sim:caseq-comp (caar sim:clause) sim:last-val sim:type)) ((do sim:item (caar sim:clause) (cdr sim:item) (null sim:item) (and (sim:caseq-comp sim:item sim:last-val sim:type) (return 'T))))) (return (sim:iprogn (cdar sim:clause)))) (setq sim:clause (cdr sim:clause)) (go TG) )) (defun sim:caseq-comp (sim:item sim:last-val sim:type) (and (not (eq sim:type (ptr-typep sim:item))) (error-1 'ITM 'CASEQ (list sim:item sim:type))) (or (eq sim:item sim:last-val) (caseq sim:type ((SYMBOL CHARACTER) (eq sim:item sim:last-val)) (FIXNUM (= sim:item sim:last-val)) (T (equal sim:item sim:last-val))))) (nil-defun DO sf-subr (sim:form-to-eval) (let (vars-list sim:all-vars stepped-vars steppers end-ret sim:body) (cond ((and (car sim:form-to-eval) (symbolp (car sim:form-to-eval))) ;Test for old-style DO (setq vars-list (list (car sim:form-to-eval) (cadr sim:form-to-eval) (caddr sim:form-to-eval)) end-ret (list (cadddr sim:form-to-eval)) sim:body (cddddr sim:form-to-eval))) ('T (pop sim:form-to-eval vars-list) (pop sim:form-to-eval end-ret) (setq sim:body (cdr sim:form-to-eval)))) ;;; "sim:all-vars" could be made into SIM:VARIABLE-BUFFER (setq sim:all-vars (mapcar '(lambda (x) (cond ((atom x) x) ((car x)))) vars-list)) (setq stepped-vars (mapcan '(lambda (x) (cond ((and (pairp x) (cddr x)) (push (caddr x) steppers) (list (car x))))) vars-list)) (progv sim:all-vars (mapcar '(lambda (x) (and (pairp x) (nil-eval (cadr x)))) vars-list) (let ((sim:special-decls-l sim:special-decls-l) (sim:cln sim:cln) (sim:blintz sim:blintz) (sim:progs sim:progs)) (prog () (sim:update-blintz sim:all-vars sim:body 'DO) (sim:update-progs () sim:body) A (and (nil-eval (car end-ret)) (return (sim:iprogn (cdr end-ret)))) (setq sim:tem (sim:prog-loop)) (and (not (eq sim:tem (prog-return-marker))) (return sim:tem)) (mapc 'SET stepped-vars (mapcar 'NIL-EVAL steppers)) (go A)))))) ;; SIM:DECOMPOSE - decompose value according to pattern (defun SIM:DECOMPOSE (sim:fun sim:pattern sim:value) (cond ((null sim:pattern)) ((symbolp sim:pattern) (funcall sim:fun sim:pattern sim:value)) ((pairp sim:pattern) (or (listp sim:value) (error-1 'WTA 'DECOMPOSE (list sim:pattern sim:value))) (sim:decompose sim:fun (car sim:pattern) (car sim:value)) (sim:decompose sim:fun (cdr sim:pattern) (cdr sim:value))) ((error-1 'ILF 'DECOMPOSE (list sim:pattern sim:value))))) (nil-defun LET sf-subr (sim:form-to-eval) (let (sim:vars sim:vals sim:value) (mapc (function (lambda (sim:item) (cond ((symbolp sim:item) (push sim:item sim:vars) (push () sim:vals)) ((pairp sim:item) (sim:decompose (function (lambda (item value) (push item sim:vars) (push value sim:vals))) (car sim:item) (nil-eval (cadr sim:item)))) ((error-1 'ILF 'LET sim:form-to-eval))))) (car sim:form-to-eval)) (sim:update-blintz sim:vars (cdr sim:form-to-eval) 'LET) (progv sim:vars sim:vals (sim:iprogn (cdr sim:form-to-eval))))) (nil-defun DESETQ sf-subr (sim:form-to-eval) (do ((sim:arglist sim:form-to-eval (cddr sim:arglist)) sim:val) ((null sim:arglist) sim:val) (and (null (cdr sim:arglist)) (error-1 'WNA 'DESETQ sim:arglist)) (sim:decompose (function set) (car sim:arglist) (setq sim:val (nil-eval (cadr sim:arglist)))))) ;; Supposedly DEFUN will eventually be a macro which expands into FSETQ. (nil-defun DEFUN sf-subr (sim:form-to-eval) (let ((argl (cdr sim:form-to-eval)) (type 'EXPR) (name (car sim:form-to-eval)) bvl ) (cond ((listp name) (setq type (cadr name) name (car name))) ((eq (car argl) 'MACRO) (pop argl) (setq type 'MACRO))) (pop argl bvl) (putprop (cond (name) ((error-1 '|NIL impermissible as function name| 'DEFUN sim:form-to-eval))) (cons-a-NILfun TYPE type ARGS bvl BODY argl) 'FUNCTION-CELL) name)) (nil-defun MACRO sf-subr (sim:form-to-eval) (let (((name . args&body) sim:form-to-eval)) (and (pairp name) (setq name (car name))) (or (symbolp name) (error-1 'WTA 'MACRO sim:form-to-eval)) (fset name `(MACRO LAMBDA ,@args&body)) name)) ;; (IF-NOT-NIL ... (nil-defun DEFMACRO macro (x) (maclisp-macroexpand x)) (nil-defun |`-expander/|| macro (x) (maclisp-macroexpand x)) (nil-defun MACROEXPANDED macro (x) (car (cddddr x))) (nil-defun MACROEXPAND nil-expr (sim:form) (and (pairp sim:form) (fboundp (car sim:form)) (let ((sim:fun (fsymeval (car sim:form)))) (and (pairp sim:fun) (eq (car sim:fun) 'MACRO) (setq sim:form (nil-funcall (cdr sim:fun) sim:form))))) sim:form) (nil-defun FSET expr-expr (&REST restv) (let ((vsiz (nil-length restv))) (or (not (oddp vsiz)) (error-1 'WNA 'FSET restv)) (do ((i 0 (+ i 2)) sym fun value type) ((not (< i vsiz)) value) (setq sym (elt restv i) fun (elt restv (1+ i)) value fun) (or (symbolp sym) (error-1 'WTA 'FSET restv)) (cond ((subrp fun)) ((pairp fun) (setq type (cond ((eq (car fun) 'MACRO) (pop fun) 'MACRO) ('EXPR))) (or (eq (car fun) 'LAMBDA) (error-1 'WTA 'FSET restv)) (setq fun (cons-a-NILfun TYPE type ARGS (cadr fun) BODY (cddr fun)))) ((error-1 'WTA 'FSET restv))) (putprop sym fun 'FUNCTION-CELL)))) (nil-defun FBOUNDP expr-expr (sym) (and (not (symbolp sym)) (error-1 'WTA 'FBOUNDP sym)) (and (get sym 'FUNCTION-CELL) *:truthity)) ;FSYMEVAL: get the contents of a function cell, as in NIL ; Returns either (LAMBDA ...), (MACRO . fun), or a "subr-pointer" ; suitable as an argument to FSET, APPLY, FUNCALL etc. (nil-defun FSYMEVAL expr-expr (sym) (cond ((or (not (symbolp sym)) (null (get sym 'FUNCTION-CELL))) (error-1 'WTA 'FSYMEVAL sym)) ((prog (fnam f-c body) (setq f-c (get sym 'FUNCTION-CELL)) (cond ((eq (NILfun-type f-c) 'SUBR) (return f-c)) ((pairp (setq fnam (NILfun-body f-c))) (setq body fnam)) ((symbolp fnam) ;kludge city! (let ((prop (getl fnam '(NIL-EXPR NIL-SUBR)))) (caseq (car prop) (NIL-EXPR (setq body `((FUNCALL ',(cadr prop))))) (NIL-SUBR (setq body `((SUBRCALL 'T (GET ',fnam 'NIL-SUBR))))) ((error-1 'LOF 'FSYMEVAL sym))))) ((error-1 'ITM 'FSYMEVAL f-c))) (setq fob `(LAMBDA ,(NILfun-args f-c) ,@body)) (cond ((eq (NILfun-type f-c) 'MACRO) (return (cons 'MACRO fob))) ((return fob))))))) ;;; sooner or later, we'll have to make this CLOSURE etc work ;;; For now a closure is like ;;; #( ) (nil-defun CLOSURE sf-subr (sim:form-to-eval) (and (or (atom sim:form-to-eval) (atom (cdr sim:form-to-eval)) (cddr sim:form-to-eval)) (error-1 '|This case can't be simulated| 'CLOSURE sim:form-to-eval)) (let ((fun (car sim:form-to-eval)) (specvars (list-to-vector (cadr sim:form-to-eval))) (valuecells (make-list (list-length (cadr sim:form-to-eval))))) (vector-to-extend (vector *:ptr-class-closure fun specvars valuecells)))) (nil-defun ERRSET macro (x) `((LAMBDA (SIM:ERRSETP SIM:EPRINTP) (CATCH 'SIM:ERRSET (LIST ,(cadr x)))) 'T ,(caddr x))) (nil-defun FLEXURE sf-subr (sim:form-to-eval) (error-1 '|You lose, bunkie!| 'FLEXURE sim:form-to-eval)) ;;; The normal "setq" (nil-defun SETQ sf-subr (sim:form-to-eval) (do ((sim:arglist sim:form-to-eval (cddr sim:arglist)) sim:val) ((null sim:arglist) sim:val) (and (null (cdr sim:arglist)) (error-1 'WNA 'SETQ sim:arglist)) (and (not (symbolp (car sim:arglist))) (error-1 '|SYMBOL required| 'SETQ sim:arglist)) (set (car sim:arglist) (setq sim:val (nil-eval (cadr sim:arglist)))))) ;;; A parallel "setq" - all evaluations are done before any bindings (nil-defun PSETQ sf-subr (sim:form-to-eval) (do ((sim:arglist sim:form-to-eval (cddr sim:arglist)) (sim:vals (do ((sim:arglist sim:form-to-eval (cddr sim:arglist)) sim:val) ((null sim:arglist) sim:val) (and (null (cdr sim:arglist)) (error-1 'WNA 'PSETQ sim:arglist)) (and (not (symbolp (car sim:arglist))) (error-1 '|SYMBOL required| 'PSETQ sim:arglist)) (push (nil-eval (cadr sim:arglist)) sim:val)) (cdr sim:vals)) sim:lastval) ((null sim:arglist) sim:lastval) (set (car sim:arglist) (setq sim:lastval (car sim:vals))))) ;;; Counterpart of "setq" for function-cells (nil-defun FSETQ sf-subr (sim:form-to-eval) (do ((sim:arglist sim:form-to-eval (cddr sim:arglist)) sim:val) ((null sim:arglist) sim:val) (and (null (cdr sim:arglist)) (error-1 'WNA 'FSETQ sim:arglist)) (and (not (symbolp (car sim:arglist))) (error-1 '|SYMBOL required| 'FSETQ sim:arglist)) (fset (car sim:arglist) (setq sim:val (nil-eval (cadr sim:arglist)))))) ;;; Counterpart of fictional SYMEVALQ for function-cells (nil-defun FSYMEVALQ sf-subr (sim:form-to-eval) (or (null (cdr sim:form-to-eval)) (error-1 'WNA 'FSYMEVALQ sim:form-to-eval)) (fsymeval (car sim:form-to-eval))) (nil-defun PROG sf-subr (sim:form-to-eval) (let ((sim:special-decls-l sim:special-decls-l) (sim:cln sim:cln) (sim:blintz sim:blintz) (sim:progs sim:progs) sim:tem) (cond ((atom sim:form-to-eval) (error-1 'IFL 'PROG sim:form-to-eval)) ((listp (car sim:form-to-eval))) ((symbolp (car sim:form-to-eval)) (pop sim:form-to-eval sim:tem)) ;extract name ((error-1 'ILF 'PROG sim:form-to-eval))) (sim:update-blintz (car sim:form-to-eval) (cdr sim:form-to-eval) 'PROG) (sim:update-progs sim:tem (cdr sim:form-to-eval)) (progv (car sim:form-to-eval) sim:NIL* (cond ((eq (setq sim:tem (sim:prog-loop)) (prog-return-marker)) () ) ('T sim:tem))))) (defun sim:update-progs (prog-name form) ;Constructs up the PROGinfo frob for PROG and DO (let ((body form)) ;(cond ((eq (caar body) 'DECLARE) ; (pop body))) (push (cons-a-PROGinfo NAME prog-name ID (gensym) FORM body CLN sim:cln) sim:progs))) (defun sim:prog-loop () ;Runs the current (most recent) PROG ;GO causes throw to here, using a gensymmed catch tag, with the spot ; at which to start prog-evaling again. ;RETURN throws to here, with a pair whose car is a special marker, and ; whose cdr is the value to be returned. ;Exit is normal, by execution of RETURN, with returned value; ; is fall-thru, indicating a value of (), with internal marker. (prog (sim:prog-form sim:ret-val) (setq sim:prog-form (PROGinfo-form (car sim:progs))) A (setq sim:prog-form (*catch (PROGinfo-id (car sim:progs)) (do ((sim:forms sim:prog-form (cdr sim:forms))) ((null sim:forms) () ) (and (pairp (car sim:forms)) (nil-eval (car sim:forms)))))) (cond ((null sim:prog-form) (return (prog-return-marker))) ((eq (car sim:prog-form) (prog-return-marker)) (return (cdr sim:prog-form))) ('T (go A))))) (nil-defun GO sf-subr (x) ;Cycle thru lexical PROGs, looking for tag. Error if not found (do ((pil (cond ((or (atom x) (cddr x)) () ) ('T sim:progs)) (cdr pil)) (tag (and (pairp x) (car x))) go-place prog-info) ((or (null pil) (< (PROGinfo-cln (car pil)) sim:lexical-cln)) (error-1 '|Can't find tag| 'GO x)) (setq prog-info (car pil)) (cond ((cdr x) (cond ((not (eq (cadr x) (PROGinfo-name prog-info)))) ((setq go-place (memq tag (PROGinfo-form prog-info))) (*throw (PROGinfo-id prog-info) go-place)) ;If this is right PROG for a named GO, but tag not found, ; then abort by setting "pil" to null. ('T (setq pil () )))) ((setq go-place (memq tag (PROGinfo-form prog-info))) (*throw (PROGinfo-id prog-info) go-place))))) (nil-defun RETURN (sim:ret-val) (and (null sim:progs) (error-1 '|Not inside PROG or DO| 'RETURN () )) (*throw (PROGinfo-id (car sim:progs)) (cons (prog-return-marker) sim:ret-val))) (nil-defun RETURN-FROM (sim:ret-val prog-name) (do ((pil sim:progs (cdr pil)) proginfo) ((null pil) (error-1 '|Not inside PROG or DO| 'RETURN-FROM prog-name)) (and (eq prog-name (PROGinfo-name (car pil))) (*throw (PROGinfo-id (car pil)) (cons (prog-return-marker) sim:ret-val))))) (nil-defun PROG1 sf-subr (sim:form-to-eval) (sim:prog1//2 sim:form-to-eval)) (nil-defun PROJ1 sf-subr (sim:form-to-eval) (sim:prog1//2 sim:form-to-eval)) (nil-defun PROG2 sf-subr (sim:form-to-eval) (let ((sim:forms-to-eval sim:form-to-eval)) (nil-eval (car sim:forms-to-eval)) (sim:prog1//2 (cdr sim:forms-to-eval)))) (defun sim:prog1//2 (sim:forms-to-eval) (prog (sim:val-to-return) (setq sim:val-to-return (nil-eval (cadr sim:forms-to-eval))) A (and (null sim:forms-to-eval) (return sim:val-to-return)) (nil-eval (car sim:forms-to-eval)) (pop sim:forms-to-eval) (go A))) (nil-defun PROGN sf-subr (sim:form-to-eval) (sim:iprogn sim:form-to-eval)) (nil-defun PROGV sf-subr (sim:forms-to-eval) (and (or (atom (cdr sim:forms-to-eval)) (atom (cddr sim:forms-to-eval)) (not (listp (car sim:forms-to-eval))) (not (listp (cadr sim:forms-to-eval)))) (error-1 '|Bad form| 'PROGV sim:forms-to-eval)) (progv (nil-eval (car sim:forms-to-eval)) (nil-eval (cadr sim:forms-to-eval)) (sim:iprogn (cddr sim:forms-to-eval)))) (defun SIM:IPROGN (sim:forms-to-eval) (prog () A (and (null (cdr sim:forms-to-eval)) (return (nil-eval (car sim:forms-to-eval)))) (nil-eval (car sim:forms-to-eval)) (pop sim:forms-to-eval) (go A))) (nil-defun CATCH sf-subr (sim:form-to-eval) (*catch (nil-eval (car sim:form-to-eval)) (sim:iprogn (cdr sim:form-to-eval)))) (nil-defun THROW sf-subr (sim:form-to-eval) (or (= (list-length sim:form-to-eval) 2) (error-1 'WNA 'THROW sim:form-to-eval)) (*throw (nil-eval (car sim:form-to-eval)) (nil-eval (cadr sim:form-to-eval)))) (nil-defun CATCHALL sf-subr (sim:form-to-eval) (let ((sim:catchallfun (nil-eval (car sim:form-to-eval)))) (catchall '(lambda (sim:tag sim:val) (nil-funcall sim:catchallfun sim:tag sim:val)) (sim:iprogn (cdr sim:form-to-eval))))) (nil-defun CATCH-BARRIER sf-subr (sim:form-to-eval) (catch-barrier (nil-eval (car sim:form-to-eval)) (sim:iprogn (cdr sim:form-to-eval)))) (nil-defun UNWIND-PROTECT sf-subr (sim:form-to-eval) (unwind-protect (nil-eval (car sim:form-to-eval)) (sim:iprogn (cdr sim:form-to-eval)))) (nil-defun EVAL-WHEN sf-subr (sim:form-to-eval) (and (memq 'EVAL (car sim:form-to-eval)) (do ((sim:forms-to-eval (cdr sim:form-to-eval) (cdr sim:forms-to-eval)) (sim:last-val () (nil-eval (car sim:forms-to-eval)))) ((null sim:forms-to-eval) sim:last-val)))) (nil-defun PUSH sf-subr (sim:form-to-eval) (set (cadr sim:form-to-eval) (cons (nil-eval (car sim:form-to-eval)) (cadr sim:form-to-eval)))) (nil-defun TYPECASEQ sf-subr (sim:form-to-eval) (sim:caseq (ptr-typep (nil-eval (car sim:form-to-eval))) (cdr sim:form-to-eval))) (comment MAPF and MAP-type funs) (nil-defun MAPF sf-subr (sim:form-to-eval) ;Original bvl = (result-type source-types fun &rest args) (let ( ((sim:arg2 sim:arg1 sim:arg3 sim:restv) sim:form-to-eval) ) (setq sim:arg3 (nil-eval sim:arg3) sim:restv (mapcar 'nil-eval sim:restv)) (let ((args-list sim:restv) (source-types (typecaseq sim:arg1 (SYMBOL (star sim:arg1)) (PAIR sim:arg1) (T (error1 'WTA 'MAPF)))) (result-type sim:arg2) (fun sim:arg3) (result-length -1) (result-max-length 17) result fxresult flresult ) (declare (fixnum fxresult) (flonum flresult)) (setq result (caseq result-type ((LIST NCONC) () ) (PROJ1 (car args-list)) (VECTOR (make-vector 20)) (STRING (make-string 20)) (BITS (make-bits 20)) ((+) (setq fxresult 0)) ((+$) (setq flresult 0.0)) (T (error-1 'BTS 'MAPF sim:arg2) ))) (setq source-types (mapcar '(lambda (type arg) (or (caseq type ((LIST CAR) (listp arg)) ((VECTOR STRING BITS) (eq (ptr-typep arg) type)) ((CONSTANT) 'T) ((1+ 1-) (eq (typep arg) 'FIXNUM)) ((1+$ 1-$) (eq (typep arg) 'FLONUM)) (T (error-1 'ITM 'MAPF (list type arg)))) (error-1 '|Unmatched arg/type| 'MAPF (list type arg))) type) source-types args-list)) (*catch 'SIM:MAPF-END (do ((end-flag 0 0) (current-result)) (()) (setq result-length (1+ result-length)) (setq current-result (nil-apply fun (maplist '(lambda (arg arg-type) (caseq (car arg-type) ((CAR LIST) (and (null (car arg)) (*throw 'SIM:MAPF-END () )) (prog2 () (caseq (car arg-type) (LIST (car arg)) (CAR (caar arg)) (T (error-1 'ITM 'MAPF (list arg arg-type)))) (rplaca arg (cdar arg)))) (STRING (cond ((not (< result-length (string-length (car arg)))) (*throw 'SIM:MAPF-END () )) ((char (car arg) result-length)))) (VECTOR (cond ((not (< result-length (vector-length (car arg)))) (*throw 'SIM:MAPF-END () )) ((vref (car arg) result-length)))) (BITS (cond ((not (< result-length (bits-length (car arg)))) (*throw 'SIM:MAPF-END () )) ((bit (car arg) result-length)))) (CONSTANT (car arg)))) args-list source-types))) (caseq result-type ((LIST NCONC) (push current-result result)) (PROJ1 () ) (VECTOR (and (> result-length result-max-length) (setq result (vector-replace (make-vector (setq result-max-length (+ 20 result-max-length))) result))) (vset result result-length current-result)) (STRING (or (characterp current-result) (error-1 '|Result must be a character| 'MAPF current-result)) (and (> result-length result-max-length) (setq result (fill-string (make-string (setq result-max-length (+ 20 result-max-length))) result))) (rplachar result result-length current-result)) (BITS (or (fixnump current-result) (error-1 '|Result must be a fixnum| 'MAPF current-result)) (and (> result-length result-max-length) (setq result (fill-bits (make-bits (setq result-max-length (+ 20 result-max-length))) result)) (rplacbit result result-length current-result))) ((+) (setq fxresult (+ current-result fxresult))) ((+$) (setq flresult (+$ current-result flresult))) ))) (caseq result-type (LIST (nreverse result)) (NCONC (do ((l result (cdr l)) (ans () (nconc (car l) ans))) ((null l) ans))) (VECTOR (set-vector-length result result-length) result) (STRING (set-string-length result result-length) result) (BITS (set-bits-length result result-length) result) (+ fxresult) (+$ flresult) (T result))))) ;Commonly used functions (nil-defun star expr-expr (ob) (let ((y (ncons ob))) (rplacd y y))) (nil-defun MAPCAR macro (sim:arg1) `(mapf (star 'car) 'list . ,(cdr sim:arg1))) (nil-defun MAPC macro (sim:arg1) `(mapf (star 'car) 'first . ,(cdr sim:arg1))) (nil-defun MAP macro (sim:arg1) `(mapf (star 'list) 'first . ,(cdr sim:arg1))) (nil-defun MAPLIST macro (sim:arg1) `(mapf (star 'list) 'first . ,(cdr sim:arg1))) (nil-defun IF macro (x) `(COND (,(cadr x) ,(caddr x)) ,(cdddr x))) (comment TYPE-conversion functions) ;;; Get new pointer to STRING with BITS type code. ***ENCODING DEPENDENT*** (nil-defun *:CHANGE-STRING-TO-BITS expr-expr (string) (cond ((symbolp string) (setq string (get-pname string))) ((not (stringp string)) (error-1 'WTA '*:CHANGE-STRING-TO-BITS string))) (sim:NEWdtp-instance 'BITS (+ (NEWdtp-SIZE string) (// (NEWdtp-SIZE string) 35.)) (NEWdtp-DATUM string))) ;;; Get new pointer to BITS with STRING type code. ***ENCODING DEPENDENT*** (nil-defun *:CHANGE-BITS-TO-STRING expr-expr (ob) (and (not (bitsp ob)) (error-1 'WTA '*:CHANGE-BITS-TO-STRING ob)) (sim:NEWdtp-instance 'STRING (- (NEWdtp-SIZE ob) (// (NEWdtp-SIZE ob) 36.)) (NEWdtp-DATUM ob))) ;;; Get new pointer to VECTOR with EXTEND type code. ***ENCODING DEPENDENT*** (nil-defun *:CHANGE-VECTOR-TO-EXTEND expr-expr (vec) (let (class) (and (or (not (vectorp vec)) (not (setq class (*:class-of vec))) (not (eq (ptr-typep class) 'EXTEND)) (not (eq (*:class-of class) *:ptr-class-class))) (error-1 'NCA '*:CHANGE-VECTOR-TO-EXTEND vec)) (sim:NEWdtp-instance 'EXTEND (NEWdtp-SIZE vec) (NEWdta-DATUM vec)))) ;;; Get new pointer to EXTEND with VECTOR type code. ***ENCODING DEPENDENT*** (nil-defun *:CHANGE-EXTEND-TO-VECTOR (ob) (and (not (eq (ptr-typep ob) 'EXTEND)) (error-1 'NCA '*:CHANGE-EXTEND-TO-VECTOR ob)) (sim:NEWdtp-instance 'VECTOR (NEWdtp-SIZE ob) (NEWdtp-DATUM ob))) ;;; Returns the pname of a symbol as a string (nil-defun GET-PNAME expr-expr (str-or-sym) (cond ((stringp str-or-sym) str-or-sym) ((symbolp str-or-sym) (setq str-or-sym (exploden str-or-sym)) (replace (make-string (length str-or-sym)) (mapcar '(lambda (x) (*:fixnum-to-character x)) str-or-sym))))) (nil-defun CHAR-TO-FIXNUM expr-expr (char) (and (not (characterp char)) (error-1 'WTA 'CHAR-TO-FIXNUM char)) (*:character-to-fixnum char)) (nil-defun FIXNUM-TO-CHAR expr-expr (num) (and (not (fixnump num)) (error-1 'WTA ' FIXNUM-TO-CHAR num)) (and (or (< num 0) (> num 127.)) (error-1 '|Number out of range| 'FIXNUM-TO-CHAR num)) (*:fixnum-to-character num)) (comment PAIRP *:class-of) (comment NIL-{TYPEP.NUMBERP.LENGTH} ) ;Uses the bootstrap definitions of "pairp", "*:class-of" and "*:set-class-of" (nil-defun PAIRP (ob) (pairp ob)) (nil-defun *:class-of (x) (*:class-of x)) (nil-defun *:set-class-of (x) (*:set-class-of x)) (nil-defun TYPEP nil-expr (ob) (let ((type (ptr-typep ob))) (cond ((memq type '(NULL PAIR)) 'LIST) ((not (eq type 'EXTEND)) type) ((vref (*:class-of ob) *:class-typep-index))))) (nil-defun NUMBERP nil-expr (ob) (caseq (ptr-typep ob) ((FIXNUM FLONUM SMALL-FLONUM) 'T) (EXTEND (sim:super-typep (*:class-of ob) 'NUMBER)))) (defun SIM:SUPER-TYPEP (class type) (cond ((eq (vref class *:class-typep-index) type)) ((prog (suprs) (setq suprs (vref class *:class-suprs-index)) ;Stop on objects that have themselves as superiors (and (memq class suprs) (return () )) A (and (null suprs) (return () )) (and (sim:super-typep (car suprs) type) (return 'T)) (pop suprs) (go A))))) (nil-defun LENGTH nil-expr (ob) (typecaseq ob (PAIR (list-length ob)) ((VECTOR EXTEND) (NEWdtp-SIZE ob)) (STRING (// (NEWdtp-SIZE ob) *:bits-per-character)) (BITS (NEWdtp-SIZE ob)) (HUNK (hunksize ob)) (CONSTANT (cond ((null ob) 0) ((error-1 'WTA 'LENGTH ob)))) (T (error-1 'WTA 'LENGTH ob)) )) (comment NIL-FLOAT) (nil-defun FLOAT nil-expr (num &OPTIONAL (type 'FLONUM) (radix 10.) (exponent 0) (precision () ) &AUX (dtype (nil-typep num)) (scale 1) ) (cond ((and (eq dtype type) (= 0 exponent) (or (not (eq type 'BIGFLOAT)) (null precision))) num) ('T (cond ((= 0 exponent)) ((or (not (fixnump radix)) (> radix 100.) (< radix 2)) (error-1 '|Illegal radix| 'FLOAT radix)) ('T (setq scale (expt radix exponent)))) (caseq dtype ((FIXNUM BIGNUM) (nil-float (cond ((and (not (onep scale)) (greaterp (setq num (times num scale)) *:max-floatable-integer) (make-bigfloat num (haulong num))) ((*:fix-to-float num)))) type)) (BIGFLOAT (and (not (eq type 'BIGFLOAT)) (error-1 '|Can't convert BIGFLOAT downwards| 'FLOAT num)) num) (FLONUM (cond ((eq type 'BIGFLOAT) (error-1 '|Can't convert small floating up to BIGFLOAT| 'FLOAT num)) ((eq type 'FLONUM) (cond ((onep scale) num) ((let ((tem (*:fix-to-float scale)) ans aans) (declare (flonum ans aans)) (and (or (not (flonump tem)) (and (<$ (setq aans (abs (setq ans (*$ num tem)))) (abs tem)) (<$ aans (abs num)) (or (>$ (abs num) 1.0) (>$ tem 1.0)))) (error-1 '|Floating overflow converting to FLONUM| 'FLOAT num)) ans)))) ((eq type 'SMALL-FLONUM) (and (or (>$ num *:max-small-flonum) (<$ num *:min-small-flonum)) (error-1 '|Too big for SMALL-FLONUM| 'FLOAT num)) (sim:NEWdtp-instance 'SMALL-FLONUM 0 num)))) (T (error-1 'WTA 'FLOAT num)))))) (comment SEQUENCE hacking functions) (comment VECTOR and LIST functions) ;;; General order of definitions in this section: ;;; accessor function ;;; updator function ;;; predicate function [this actually appears in the "macmac" section] ;;; creation function ;;; length function [this actually appears in the "macmac" section] ;;; set-length function ;;; NOTE WELL: both LIST-ELT and LIST-SETELT have the first two args ;;; reversed in comparison to NTH and SETNTH (nil-defun LIST-ELT expr-expr (seq index) (nth index seq)) (nil-defun LIST-SETELT expr-expr (seq index item) (rplaca (nthcdr index seq) item) seq) (nil-defun MAKE-LIST expr-expr (count) (do ((l () (cons () l)) (n count (1- n))) ((< n 1) l) (declare (fixnum n)))) (nil-defun SET-LIST-LENGTH expr-expr (list length) (or (listp list) (error-1 'WTA 'SET-LIST-LENGTH)) (and (or (not (fixnump length)) (< length 1)) (error-1 'BIS 'SET-LIST-LENGTH)) (let ((old-length (length list))) (cond ((< length old-length) (rplacd (nthcdr (1- length) list) () )) ((> length old-length) (rplacd (last list) (make-list (- length old-length))))) l)) (nil-defun VREF (vec index) (or (vectorp vec) (error-1 'WTA 'VREF vec)) (and (or (not (fixnump index)) (not (< index (NEWdtp-SIZE vec)))) (error-1 'BIS 'VREF index)) (vref vec index)) (nil-defun VSET (vec index val) (or (vectorp vec) (error-1 'WTA 'VSET vec)) (and (or (not (fixnump index)) (not (< index (NEWdtp-SIZE vec)))) (error-1 'BIS 'VSET index)) (vset vec index val)) (nil-defun MAKE-VECTOR expr-expr (len) (sim:NEWdtp-instance 'VECTOR len '( () ) )) (nil-defun SET-VECTOR-LENGTH expr-expr (vec len) (and (not (vectorp vec)) (error-1 'WTA 'SET-VECTOR-LENGTH vec)) ;Can only decrease the length of a vector (and (> len (NEWdtp-SIZE vec)) (error-1 'CUL 'SET-VECTOR-LENGTH (list vec len))) (setvst (NEWdtp-SIZE vec) len) vec) (comment STRING functions) (nil-defun CHAR (string index) (or (stringp string) (error-1 'WTA 'CHAR string)) (and (or (not (fixnump index)) (not (< (* index *:bits-per-character) (NEWdtp-SIZE string)))) (error-1 'BIS 'CHAR index)) (char string index)) (nil-defun RPLACHAR (string index char) (or (stringp string) (error-1 'WTA 'RPLACHAR string)) (and (or (not (fixnump index)) (not (< (* index *:bits-per-character) (NEWdtp-SIZE string)))) (error-1 'BIS 'RPLACHAR index)) (or (characterp char) (error-1 'WTA 'RPLACHAR char)) (rplachar string index char) char) (nil-defun MAKE-STRING expr-expr (number-of-elts) (sim:NEWdtp-instance 'STRING (* *:bits-per-character number-of-elts) () )) (nil-defun STRING expr-expr (&REST sim:restv) (replace (make-string (vector-length sim:restv)) sim:restv)) (nil-defun SET-STRING-LENGTH expr-expr (str new-length) (or (stringp str) (error-1 'WTA 'SET-STRING-LENGTH str)) (and (or (not (fixnump new-length)) (> (* new-length *:bits-per-character) (NEWdtp-SIZE str))) (error-1 'CUL 'SET-STRING-LENGTH (list str new-length))) (setvst (NEWdtp-SIZE str) (* new-length *:bits-per-character)) str) (comment BITS functions) (nil-defun BIT (bits index) (or (bitsp bits) (error-1 'WTA 'BIT bits)) (and (or (not (fixnump index)) (not (< index (NEWdtp-SIZE bits)))) (error-1 'BIS 'BIT index)) (bit bits index)) (nil-defun RPLACBIT (bits index newbit) (or (bitsp bits) (error-1 'WTA 'RPLACBIT bits)) (and (or (not (fixnump index)) (not (< index (NEWdtp-SIZE bits)))) (error-1 'BIS 'RPLACBIT index)) (or (fixnump newbit) (error-1 'WTA 'RPLACBIT newbit)) (rplacbit bits index newbit) newbit) (nil-defun MAKE-BITS expr-expr (number-of-elts) (sim:NEWdtp-instance 'BITS number-of-elts () )) (nil-defun BITS expr-expr (&REST sim:restv) (replace (make-bits (vector-length sim:restv)) sim:restv)) (nil-defun SET-BITS-LENGTH expr-expr (str new-length) (or (bitsp str) (error-1 'WTA 'SET-BITS-LENGTH str)) ;Can only decrease the size of a BITS (or (< new-length (NEWdtp-SIZE str)) (error-1 'CUL 'SET-BITS-LENGTH (list str new-length))) (setvst (NEWdtp-SIZE str) new-length) str) (nil-defun NIBBLE expr-expr (bits index count) (declare (fixnum index count n current-index ac)) (or (bitsp bits) (error-1 'WTA 'NIBBLE bits)) (do ((ac 0 (+ (lsh ac 1) (bit bits index))) (index index (1+ index))) ((< count 1) ac) (setq count (1- count)))) (nil-defun SET-NIBBLE expr-expr (bits index count n) (declare (fixnum index count n current-index ac)) (or (bitsp bits) (error-1 'WTA 'SET-NIBBLE bits)) (do ((current-index (+ -1 index count) (1- current-index)) (ac n (lsh ac -1))) ((< count 1) bits) (rplacbit bits current-index (boole 1 ac 1)) (setq count (1- count)))) (comment SPECIFIC sequence functions) ;;; The macro GEN-SPECIFICSEQFUNS is used to define the data-type specific ;;; functions that are essentially the same algorithm on args ;;; of differing type. The generic functions will do type ;;; conversions and then dispatch to one of the routines ;;; defined by this macro. (defmacro GEN-SPECIFICSEQFUNS (datatype (select setfrob . more-funs) &AUX (exlnm (explodec datatype))) ;more-funs ?=? (typerp creator lngthof) (let ((typerp (or (nth 0 more-funs) (implode (append exlnm '(P))))) (creator (or (nth 1 more-funs) (implode (append '(M A K E /-) exlnm)))) (lngthof (or (nth 2 more-funs) (implode (append exlnm '(/- L E N G T H))))) (subseq (implode (append exlnm '(/- S U B S E Q)))) (fill (implode (append exlnm '(/- F I L L)))) (replace (implode (append exlnm '(/- R E P L A C E)))) (append (implode (append exlnm '(/- A P P E N D)))) (reverse (implode (append exlnm '(/- R E V E R S E)))) (nreverse (implode (append exlnm '(/- N R E V E R S E)))) (pos (implode (append exlnm '(/- P O S)))) (posq (implode (append exlnm '(/- P O S Q)))) (position (implode (append exlnm '(/- P O S I T I O N)))) (sear (implode (append exlnm '(/- S E A R)))) (searq (implode (append exlnm '(/- S E A R Q)))) (search (implode (append exlnm '(/- S E A R C H)))) (mismat (implode (append exlnm '(/- M I S M A T)))) (mismatq (implode (append exlnm '(/- M I S M A T Q)))) (mismatch (implode (append exlnm '(/- M I S M A T C H)))) ) `(PROGN 'COMPILE (NIL-DEFUN ,subseq EXPR-EXPR (SEQ1 INDEX &OPTIONAL (COUNT (- (,lngthof SEQ1) INDEX))) (OR (,typerp SEQ1) (ERROR-1 'WTA ',subseq SEQ1)) (AND (OR (NOT (FIXNUMP INDEX)) (NOT (FIXNUMP COUNT)) (> (+ INDEX COUNT) (,lngthof SEQ1))) (ERROR-1 'BIS ',subseq (LIST SEQ1 INDEX COUNT))) (DO ((SEQ2 (,creator COUNT)) (OFFSET (+ COUNT INDEX)) (I COUNT (1- I))) ((< I 1) SEQ2) (DECLARE (FIXNUM I OFFSET)) (,setfrob SEQ2 (- COUNT I) (,select SEQ1 (- OFFSET I))))) (NIL-DEFUN ,fill EXPR-EXPR (SEQ1 ELT &OPTIONAL (INDEX 0) (COUNT (- (,lngthof SEQ1) INDEX))) (AND (> (+ INDEX COUNT) (,lngthof SEQ1)) (ERROR-1 'BIS ',fill INDEX)) (DO () ((= COUNT 0) SEQ1) (,setfrob SEQ1 INDEX ELT) (SETQ COUNT (1- COUNT) INDEX (1+ INDEX)))) (NIL-DEFUN ,replace EXPR-EXPR (SEQ1 SEQ2 &OPTIONAL (I1 0) (I2 0) (COUNT (min (- (,lngthof SEQ1) I1) (- (,lngthof SEQ2) I2)))) (DECLARE (FIXNUM I I1 I2 COUNT L-SEQ1 L-SEQ2)) ,(and (eq typerp 'STRINGP) ;If hacking strings, convert to string `(and (symbolp seq1) (setq seq1 (get-pname seq1)))) ,(and (eq typerp 'STRINGP) ;If hacking strings, convert to string `(and (symbolp seq2) (setq seq2 (get-pname seq2)))) (OR (,typerp SEQ1) (ERROR-1 'WTA ',replace SEQ1)) (OR (,typerp SEQ2) (ERROR-1 'WTA ',replace SEQ2)) (LET ((L-SEQ1 (,lngthof SEQ1)) (L-SEQ2 (,lngthof SEQ2)) TEMP ) (AND (> (+ I1 COUNT) L-SEQ1) (ERROR-1 'BIS ',replace I1)) (AND (> (+ I2 COUNT) L-SEQ2) (ERROR-1 'BIS ',replace I2)) (DO I 0 (1+ I) (NOT (< I COUNT)) (,setfrob SEQ1 (+ I I1) (,select SEQ2 (+ I I2)))) SEQ1)) (NIL-DEFUN ,append EXPR-EXPR (&REST OBS) (DECLARE (FIXNUM MX I COUNT CURRENT-I)) (OR OBS (ERROR-1 'WNA ',append OBS)) (DO ((MX (VECTOR-LENGTH OBS)) (NEW-OB (,creator (DO ((I (1- (VECTOR-LENGTH OBS)) (1- I)) (COUNT 0 (+ COUNT (,lngthof (VREF OBS I))))) ((< I 1) COUNT)))) (I 0 (1+ I)) (CURRENT-I 0 (+ CURRENT-I (,lngthof (VREF OBS I))))) ((NOT (< I MX)) NEW-OB) ;Use REPLACE to fill new object (,replace NEW-OB (VREF OBS I) CURRENT-I 0))) (NIL-DEFUN ,reverse EXPR-EXPR (OB) (DECLARE (FIXNUM I MX)) (LET ((MX (1- (,lngthof OB)))) (DO ((NEW-OB (,creator (1+ MX))) (I 0 (1+ I))) ((> I MX) NEW-OB) (,setfrob NEW-OB (- MX I) (,select OB I))))) (NIL-DEFUN ,nreverse EXPR-EXPR (OB) (DECLARE (FIXNUM I J MX)) (LET ((MX (,lngthof OB))) (DO ((I 0 (1+ I)) (J (1- MX) (1- J))) ((NOT (< I J)) OB) (,setfrob OB I (PROG2 () (,select OB J) (,setfrob OB J (,select OB I))))))) (NIL-DEFUN ,position EXPR-EXPR (sim:ITEM sim:SEQ &REST sim:RESTV) (COND (sim:RESTV (APPLY ',pos `(EQUAL ,sim:ITEM ,sim:SEQ ,@(sequence-to-list sim:RESTV)))) ((,pos 'EQUAL sim:ITEM sim:SEQ)))) (NIL-DEFUN ,posq EXPR-EXPR (sim:ITEM sim:SEQ &REST sim:RESTV) (COND (sim:RESTV (APPLY ',pos `(EQ ,sim:ITEM ,sim:SEQ ,@(sequence-to-list sim:RESTV)))) ((,pos 'EQ sim:SEQ sim:ITEM)))) (NIL-DEFUN ,pos EXPR-EXPR (sim:PRED sim:ITEM sim:SEQ &OPTIONAL (sim:INDEX 0) (sim:CNTR (- (,lngthof sim:SEQ) sim:INDEX))) (DECLARE (FIXNUM sim:INDEX sim:CNTR)) (PROG () (AND (> (+ sim:INDEX sim:CNTR) (,lngthof sim:SEQ)) (ERROR-1 'BIS ',pos sim:INDEX)) A (AND (< sim:CNTR 1) (RETURN () )) (AND (CASEQ sim:PRED (EQ (EQ sim:ITEM (,select sim:SEQ sim:INDEX))) (EQUAL (EQUAL sim:ITEM (,select sim:SEQ sim:INDEX))) (= (= sim:ITEM (,select sim:SEQ sim:INDEX))) (EQCAR (EQ sim:ITEM (CAR (,select sim:SEQ sim:INDEX)))) (T (NIL-FUNCALL sim:PRED sim:ITEM (,select sim:SEQ sim:INDEX)))) (RETURN sim:INDEX)) (SETQ sim:CNTR (1- sim:CNTR) sim:INDEX (1+ sim:INDEX)) (GO A))) (NIL-DEFUN ,search EXPR-EXPR (sim:SEQ sim:ITEM &REST sim:RESTV) (COND (sim:RESTV (APPLY ',sear `(EQUAL ,sim:SEQ ,sim:ITEM ,@(sequence-to-list sim:RESTV)))) ((,sear 'EQUAL sim:SEQ sim:ITEM)))) (NIL-DEFUN ,searq EXPR-EXPR (sim:SEQ sim:ITEM &REST sim:RESTV) (COND (sim:RESTV (APPLY ',sear `(EQ ,sim:SEQ ,sim:ITEM ,@(sequence-to-list sim:RESTV)))) ((,sear 'EQ sim:SEQ sim:ITEM)))) (NIL-DEFUN ,sear EXPR-EXPR (sim:PRED sim:SEQ sim:ITEM &OPTIONAL (sim:INDEX 0) (sim:CNTR (- (,lngthof sim:SEQ) sim:INDEX))) (DECLARE (FIXNUM sim:INDEX sim:CNTR sim:SEQ-length sim:ITEM-length sim:OFFSET)) (PROG (sim:SEQ-len sim:ITEM-len sim:ITEM-first sim:MATCH-index) (SETQ sim:SEQ-len (,lngthof sim:SEQ) sim:ITEM-len (,lngthof sim:ITEM)) (AND (= sim:ITEM-len 0) (RETURN 0)) (SETQ sim:ITEM-first (,select sim:ITEM 0)) A (AND (OR (< sim:CNTR 1) (> (+ sim:ITEM-len sim:INDEX) sim:SEQ-len)) (RETURN () )) (AND (CASEQ sim:PRED (EQ (EQ sim:ITEM-first (,select sim:SEQ sim:INDEX))) (EQUAL (EQUAL sim:ITEM-first (,select sim:SEQ sim:INDEX))) (= (= sim:ITEM-first (,select sim:SEQ sim:INDEX))) (T (NIL-FUNCALL sim:PRED sim:ITEM-first (,select sim:SEQ sim:INDEX)))) ;; If the inner do loop finds a match, then it returns ;; the starting index. This will cause MATCH-index ;; to be set non-(), thereby returning from the outer ;; do by executing the remaining clause of the AND (SETQ sim:MATCH-index (DO ((sim:OFFSET 1 (1+ sim:OFFSET))) ((NOT (< sim:OFFSET sim:ITEM-len)) sim:INDEX) (OR (LET ((sim:ELT-1 (,select sim:ITEM sim:OFFSET)) (sim:ELT-2 (,select sim:SEQ (+ sim:INDEX sim:OFFSET)))) (CASEQ sim:PRED (EQ (EQ sim:ELT-1 sim:ELT-2)) (EQUAL (EQUAL sim:ELT-1 sim:ELT-2)) (= (= sim:ELT-1 sim:ELT-2)) (T (NIL-FUNCALL sim:PRED sim:ELT-1 sim:ELT-2)))) ;Return () for failure (RETURN () )))) ;Won, return subob index (RETURN sim:MATCH-index)) (SETQ sim:INDEX (1+ sim:INDEX) sim:CNTR (1- sim:CNTR)) (GO A))) (NIL-DEFUN ,mismatch EXPR-EXPR (sim:SEQ sim:ITEM &REST sim:RESTV) (COND (sim:RESTV (APPLY ',mismat `(EQUAL ,sim:SEQ ,sim:ITEM ,@(sequence-to-list sim:RESTV)))) ((,mismat 'EQUAL sim:SEQ sim:ITEM)))) (NIL-DEFUN ,mismatq EXPR-EXPR (sim:SEQ sim:ITEM &REST sim:RESTV) (COND (sim:RESTV (APPLY ',mismat `(EQ ,sim:SEQ ,sim:ITEM ,@(sequence-to-list sim:RESTV)))) ((,mismat 'EQ sim:ITEM sim:SEQ)))) (NIL-DEFUN ,mismat EXPR-EXPR (sim:SEQ1 sim:SEQ2 &OPTIONAL (sim:I1 0) (sim:I2 0) (sim:CNTR (- (,lngthof sim:SEQ1) sim:I1))) (DECLARE (FIXNUM sim:I sim:I1 sim:I2 sim:CNTR)) ,(and (eq typerp 'STRINGP) ;If hacking strings, convert to string `(and (symbolp seq1) (setq seq1 (get-pname seq1)))) ,(and (eq typerp 'STRINGP) ;If hacking strings, convert to string `(and (symbolp seq2) (setq seq2 (get-pname seq2)))) (OR (,typerp sim:SEQ1) (ERROR-1 'WTA ',mismat sim:SEQ1)) (OR (,typerp sim:SEQ2) (ERROR-1 'WTA ',mismat sim:SEQ2)) (AND (> (+ sim:I1 sim:CNTR) (,lngthof sim:SEQ1)) (ERROR-1 'BIS ',mismat sim:I1)) (AND (> (+ sim:I2 sim:CNTR) (,lngthof sim:SEQ2)) (ERROR-1 'BIS ',mismat sim:I1)) (DO ((sim:I 0 (1+ sim:I)) sim:ELT1 sim:ELT2 ) ((= sim:CNTR sim:I) () ) (SETQ sim:ELT1 (,select sim:SEQ1 (+ sim:I sim:I1)) sim:ELT2 (,select sim:SEQ2 (+ sim:I sim:I2))) (AND (CASEQ sim:PRED (EQ (EQ sim:ELT1 sim:ELT2)) (EQUAL (EQUAL sim:ELT1 sim:ELT2)) (= (= sim:ELT1 sim:ELT2)) (T (NIL-FUNCALL sim:PRED sim:ELT1 sim:ELT2))) (RETURN sim:INDEX)))) ) )) ;;; Now define the operations on the sequences (gen-specificseqfuns LIST (list-elt list-setelt)) (gen-specificseqfuns VECTOR (vref vset)) (gen-specificseqfuns STRING (char rplachar)) (gen-specificseqfuns BITS (bit rplacbit)) (comment GENERIC sequence functions) ;;; (GEN-GENERICSEQFUN FOO ) generates a NIL-DEFUN for ;;; the generic FOO function, which more-or-less dispatches to the ;;; specific LIST-FOO, VECTOR-FOO, STRING-FOO, or BITS-FOO function ;;; depending on input. If the names for the specific primitives are ;;; non-standard, they are supplied, in order, in the optional . ;;; For NTH and SETNTH, the order of the first and second ;;; arguments must be reversed. (defmacro GEN-GENERICSEQFUN (seq-fn arglist &OPTIONAL specific-funs-l &AUX (exlfn (explodec seq-fn)) ) (let ((list-fn (or (nth 0 specific-funs-l) (implode (append '(L I S T /-) exlfn)))) (vector-fn (or (nth 1 specific-funs-l) (implode (append '(V E C T O R /-) exlfn)))) (string-fn (or (nth 2 specific-funs-l) (implode (append '(S T R I N G /-) exlfn)))) (bits-fn (or (nth 3 specific-funs-l) (implode (append '(B I T S /-) exlfn)))) (pass-args (mapcan '(lambda (x) (cond ((eq x '&OPTIONAL) ()) ((symbolp x) (list x)) ((pairp x) (list (car x))) ((error '|Illegal LAMBDA list| 'gen-genericseqfun arglist)) )) arglist))) `(NIL-DEFUN ,seq-fn ,(cond ((get seq-fn 'FUNCTION-CELL) 'EXPR) ('EXPR-EXPR)) ,arglist (TYPECASEQ sim:SEQ (PAIR (,list-fn ,@pass-args)) (VECTOR (,vector-fn ,@pass-args)) (STRING (,string-fn ,@pass-args)) (BITS (,bits-fn ,@pass-args)) (CONSTANT (COND ((NULL sim:SEQ) (,list-fn ,@pass-args)) ((error-1 'WTA ',seq-fn sim:SEQ)))) (T (error-1 'WTA ',seq-fn sim:SEQ)))))) (gen-genericseqfun SUBSEQ (sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start)))) (gen-genericseqfun FILL (sim:seq sim:item &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start)))) (gen-genericseqfun ELT (sim:seq sim:index) (list-elt vref char bit)) (gen-genericseqfun SETELT (sim:seq sim:index sim:val) (list-setelt vset rplachar rplacbit)) (gen-genericseqfun REVERSE (sim:seq)) (gen-genericseqfun NREVERSE (sim:seq)) (gen-genericseqfun POSITION (sim:item sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start)))) (gen-genericseqfun POSQ (sim:item sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start)))) (gen-genericseqfun POS (sim:pred sim:item sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start)))) (gen-genericseqfun SEARCH (sim:pat sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start (1+ (nil-length sim:pat)) )))) (gen-genericseqfun SEARQ (sim:pat sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start (1+ (nil-length sim:pat)) )))) (gen-genericseqfun SEAR (sim:pred sim:pat sim:seq &OPTIONAL (sim:start 0) (sim:cnt (- (nil-length sim:seq) sim:start (1+ (nil-length sim:pat)) )))) (gen-genericseqfun MISMATCH (sim:seq sim:seq2 &OPTIONAL (sim:i1 0) (sim:i2 0) (sim:cnt (min (- (nil-length sim:seq) i1) (- (nil-length sim:seq2) i2))))) (gen-genericseqfun MISMATQ (sim:seq sim:seq2 &OPTIONAL (sim:i1 0) (sim:i2 0) (sim:cnt (min (- (nil-length sim:seq) i1) (- (nil-length sim:seq2) i2))))) (gen-genericseqfun MISMAT (sim:pred sim:seq sim:seq2 &OPTIONAL (sim:i1 0) (sim:i2 0) (sim:cnt (min (- (nil-length sim:seq) i1) (-(nil-length sim:seq2) i2))))) (nil-defun APPEND nil-expr (seq &rest v) (and (not (sequencep seq)) (error-1 'WTA 'APPEND seq)) (cond ((null v) (subseq seq 0)) ((let ((vsiz (vector-length v)) (seqsiz (nil-length seq)) (newsiz 0) (result-type (ptr-typep seq)) newob temp len ) (declare (fixnum vsiz seqsiz newsiz i current-i len)) (do i 0 (1+ i) (not (< i vsiz)) (setq temp (vref v i) newsiz (+ newsiz (nil-length temp))) (and (not (sequencep temp)) (error-1 'WTA 'APPEND seq)) (typecaseq temp ((PAIR CONSTANT) (setq result-type 'LIST)) (VECTOR (and (not (eq result-type 'LIST)) (setq result-type 'VECTOR))) (STRING (and (not (memq result-type '(LIST VECTOR))) (setq result-type 'STRING))))) (setq newsiz (+ seqsiz newsiz)) (setq newob (caseq result-type (LIST (make-list newsiz)) (VECTOR (make-vector newsiz)) (STRING (make-string newsiz)) (BITS (make-bits newsiz)))) (cond (newob (replace newob seq 0 0 seqsiz) (do ((i 0 (1+ i)) (current-i seqsiz (+ current-i len)) ) ((not (< i vsiz)) ) (setq temp (vref v i)) (setq len (nil-length temp)) (replace newob temp current-i 0 len)))) newob)))) (nil-defun REPLACE expr-expr (v1 v2 &OPTIONAL (i1 0) (i2 0) (cntr (min (- (nil-length v1) i1) (- (nil-length v2) i2)))) (declare (fixnum i1 i2 i ix1 ix2)) (and (or (not (sequencep v1)) (not (sequencep v2))) (error-1 'WTA 'REPLACE (list v1 v2))) (let ((tp1 (ptr-typep v1)) (tp2 (ptr-typep v2)) (ans v1) (ocntr cntr) l1 l2 ) (cond ((and (eq tp1 tp2)) (caseq tp1 (VECTOR (vector-replace v1 v2 i1 i2 cntr)) (STRING (string-replace v1 v2 i1 i2 cntr)) (PAIR (list-replace v1 v2 i1 i2 cntr)) (BITS (bits-replace v1 v2 i1 i2 cntr)))) ('T (setq l1 (nil-length v1) l2 (nil-length v2)) (and (eq cntr sim:unique) (> (setq cntr (- l2 i2)) (- l1 i1)) (setq cntr (- l1 i1))) (and (or (> (+ i1 cntr) l1) (> (+ i2 cntr) l2)) (error-1 'BIS 'REPLACE (list v1 v2 i1 i2 ocntr))) (and (eq tp1 'PAIR) (setq v1 (nthcdr i1 v1))) (and (eq tp2 'PAIR) (setq v2 (nthcdr i2 v2))) (do ((i 0 (1+ i)) (ix2 i2 (1+ i2)) new-item) ((not (< i cntr)) ) (setq new-item (caseq tp2 (VECTOR (vref v2 ix2)) (PAIR (pop v2)) (STRING (char v2 ix2)) (BITS (bit v2 ix2)))) (caseq tp1 (VECTOR (vset v1 (+ i i1) new-item)) (PAIR (rplaca v1 new-item) (pop v1)) (STRING (rplachar v1 (+ i i1) new-item)) (BITS (rplacbit v1 (+ i i1) new-item)))) ans)))) (comment DRAMP) ;;; This macro requires "x" to be a symbol, and the following variables set up: ;;; ELT PRED EXTRACTOR (defmacro dramp-list-pred (x) `((LAMBDA (ITEM) (CASEQ PRED (EQ (EQ ELT ITEM)) (EQUAL (EQUAL ELT ITEM)) (= (= ELT ITEM)) (=$ (=$ ELT ITEM)) (T (NIL-FUNCALL PRED ELT ITEM)))) (CASEQ EXTRACTOR (CAR (CAR ,x)) (CAAR (CAAR ,x)) (CDAR (CDAR ,x)) (PROJ1 ,x) (T (NIL-FUNCALL EXTRACTOR ,x))))) (nil-defun DRAMP expr-expr (op extractor pred elt list &optional (rpt *:max-fixnum)) (declare (fixnum rpt)) (or (listp list) (and (vectorp list) (memq op '(ASS POS))) (error-1 'WTA 'DRAMP list)) (caseq op (DEL (do () ((or (null list) (< rpt 1) (not (dramp-list-pred list)))) (setq list (cdr list) rpt (1- rpt))) (do ((prev-list list (cdr prev-list)) (curr-list (cdr list) (cdr curr-list))) ((or (null curr-list) (< rpt 1)) list) (cond ((dramp-list-pred curr-list) (rplacd prev-list (cdr curr-list)) (setq rpt (1- rpt)))))) (REM (do ((new-list () ) (curr-list list (cdr curr-list))) ((or (null curr-list) (< rpt 1)) (nreconc new-list curr-list)) (cond ((dramp-list-pred curr-list) (setq rpt (1- rpt))) ((setq new-list (cons (car curr-list) new-list)))))) ((ASS POS) (cond ((vectorp list) (setq extractor (cdr (assq extractor '((CAR . PROJ1) (CAAR . CAR) (CDAR . CDR))))) (and (null extractor) (error-1 '|Bad "extractor" to ASS on a VECTOR| 'DRAMP extractor)) (do ((i 0 (1+ i)) (n (1- (vector-length list))) (v list) (item) ) ((not (< i n)) () ) (declare (fixnum i n)) (setq item (vref v i)) (and (dramp-list-pred item) (return (cond ((eq op 'ASS) item) (i)))))) ((do ((l list (cdr l))) ((or (null l) (dramp-list-pred l)) (car l)))))) (MEM (do ((l list (cdr l))) ((or (null l) (dramp-list-pred l)) l))) )) (comment Functions calling DRAMP) (comment MULTIPLE-<> etc) (defmacro gen-dramp-functions (generic-nm (typ ex) funs &AUX (preds '(EQUAL EQ = =$))) `(PROGN 'COMPILE (NIL-DEFUN ,generic-nm (sim:pred sim:arg1 sim:arg2) (DRAMP ',typ ',ex sim:pred sim:arg1 sim:arg2)) ,@(mapcan '(lambda (fun pred) (and (not (get fun 'FUNCTION-CELL)) (list `(NIL-DEFUN ,fun (sim:arg1 sim:arg2) (DRAMP ',typ ',ex ',pred sim:arg1 sim:arg2))))) funs preds))) (gen-dramp-functions DEL (DEL CAR) (DELETE DELQ DEL= DEL=$)) (gen-dramp-functions REM (REM CAR) (REMOVE REMQ REM= REM=$)) (gen-dramp-functions ASS (ASS CAAR) (ASSOC ASSQ ASS= ASS=$)) (gen-dramp-functions RASS (ASS CDAR) (RASSOC RASSQ RASS= RASS=$)) (gen-dramp-functions MEM (MEM CAR) (MEMBER MEMQ MEM= MEM=$)) (gen-dramp-functions MEMASS (MEM CAAR) (MEMASSOC MEMASSQ MEMASS= MEMASS=$)) (gen-dramp-functions DELASS (DEL CAAR) (DELASSOC DELASSQ DELASS= DELASS=$)) (gen-dramp-functions POSASS (POS CAAR) (POSASSOC POSASSQ POSASS= POSASS=$)) ;;; Functional to help with macro-redefinition of < and >, in NIL, ;;; in order to accept multiple arguments (nil-defun MULTIPLE-<> expr-expr (sim:fun sim:item-arg &rest sim:-restv) (do ((sim:nth-cnt (vector-length sim:-restv)) (sim:index 0 (1+ sim:index))) ((not (< sim:index sim:nth-cnt)) *:truthity) (and (not (funcall sim:fun sim:item-arg (setq sim:item-arg (vref sim:-restv sim:index)))) (return () )) )) (defmacro gen-<>-macro l `(PROGN 'COMPILE ,@(mapcar '(lambda (fun) `(NIL-DEFUN ,fun macro (x) `(MULTIPLE-<> ',',fun ,@(cdr x)))) l))) (gen-<>-macro < > <= >= <$ >$ <=$ >=$ ) ;;; Fill out the numerical comparison subrs - must not be macros, for ;;; the functional tries to apply them (defun <= (x y) (not (> x y))) (defun >= (x y) (not (< x y))) (defmacro gen-flcmpfn (fun genfun) (let ((emsg (implode (nconc (explodec '|Non flonum - |) (explodec fun))))) `(DEFUN ,fun (X Y) (PROG () A (COND ((NOT (EQ (TYPEP X) 'FLONUM)) (SETQ X (ERROR ',emsg X 'WRNG-TYPE-ARG)) (GO A))) B (COND ((NOT (EQ (TYPEP Y) 'FLONUM)) (SETQ Y (ERROR ',emsg Y 'WRNG-TYPE-ARG)) (GO B))) (RETURN (,genfun X Y)))))) (gen-flcmpfn <$ <) (gen-flcmpfn <=$ <=) (gen-flcmpfn =$ =) (gen-flcmpfn >=$ >=) (gen-flcmpfn >$ >) (comment mixed VECTOR/LIST funs) ;;; Two helpful functions for en"list"ing and en"vector"ing (nil-defun VECTOR-TO-LIST expr-expr (vec &OPTIONAL (index 0) (cnt sim:unique) ) (cond ((not (vectorp vec)) (error-1 'WTA 'VECTOR-TO-LIST vec)) ((let ((len (vector-length vec))) (declare (fixnum len)) (cond ((eq cnt sim:unique) (setq cnt (- len index))) ((> (+ index cnt) len) (error-1 'BIS 'VECTOR-TO-LIST (list index cnt)))) (replace (make-list cnt) vec 0 index cnt))))) (nil-defun LIST-TO-VECTOR expr-expr (list &OPTIONAL (index 0) (cnt sim:unique)) (cond ((null list) () ) ((not (listp list)) (error-1 'WTA LIST-TO-VECTOR list)) ((let ((len (list-length list))) (declare (fixnum len)) (cond ((eq cnt sim:unique) (setq cnt (- len index))) ((> (+ index cnt) len) (error-1 'BIS 'LIST-TO-VECTOR (list index cnt)))) (replace (make-vector cnt) list 0 index cnt))))) (nil-defun SEQUENCE-TO-LIST expr-expr (seq) (cond ((listp seq) seq) ((vectorp seq) (vector-to-list seq)) ((stringp seq) (string-to-list seq)) ((bitsp seq) (bits-to-list seq)) ((error-1 'WTA 'SEQUENCE-TO-LIST seq)))) (nil-defun SEQUENCE-TO-VECTOR expr-expr (seq) (cond ((vectorp seq) seq) ((listp seq) (list-to-vector seq)) ((stringp seq) (string-to-vector seq)) ((bitsp seq) (bits-to-vector seq)) ((error-1 'WTA 'SEQUENCE-TO-VECTOR seq)))) (nil-defun VECTOR expr-expr (&rest sim:restv) ;copy the rest-vector (vector-subseq sim:restv 0)) (nil-defun GET nil-expr (arg prop) (cond ((vectorp arg) (do ((len (vector-length arg)) (i 0 (+ i 2))) ((not (< i len)) () ) (declare (fixnum i len)) (and (eq (vref arg i) prop) (return (vref arg (1+ i)))))) ((get arg prop)))) (nil-defun EQ (ob item) (and (eq ob item) *:truthity)) (nil-defun ATOM (ob) (and (not (pairp ob)) *:truthity)) (nil-defun NOT (ob) (and (not ob) *:truthity)) (nil-defun NULL (ob) (and (null ob) *:truthity)) (nil-defun LOAD (sim:arg1) (let ((sim:load-stream (open sim:arg1 '(IN ASCII)))) (do ((INFILE sim:load-stream) (sim:arg0)) (()) (and (eq sim:unique (setq sim:arg0 (read sim:load-stream sim:unique))) (return (close sim:load-stream))) (nil-eval sim:arg0)))) ;;; Like (STATUS FEATURE mumble) (nil-defun FEATUREP expr-expr (sym) (apply 'STATUS (list 'FEATURE sym))) ;;; Accepts a symbol or a string and interns it on the current obarray (nil-defun INTERN (sym-or-str &OPTIONAL (OBARRAY OBARRAY)) (cond ((symbolp sym-or-str) (intern sym-or-str)) ((stringp sym-or-str) (implode (do ((i (1- (string-length sym-or-str)) (1- i)) l) ((< i 0) l) (declare (fixnum i)) (push (*:character-to-fixnum (char sym-or-str i)) l) ))) ((error-1 'WTA 'INTERN sym-or-str)))) (comment I/O) (nil-defun IN (sim:stream) (sim:stream-inbuffer-op sim:stream 'T 'FIXNUM () )) (nil-defun INCH expr-expr (&OPTIONAL (sim:stream INFILE) (sim:peekarg *:eof-character)) (sim:stream-inbuffer-op simi:stream 'CHARACTER 'T sim:peekarg)) (nil-defun INCHPEEK expr-expr (&OPTIONAL (sim:stream INFILE) (sim:peekarg *:eof-character)) (sim:stream-inbuffer-op sim:stream 'CHARACTER () sim:peekarg)) (nil-defun OUCH expr-expr (sim:arg1 &OPTIONAL (sim:stream OUTFILES)) ;Original = (char &OPTIONAL stream) (tyo (char-to-fixnum sim:arg1) sim:stream) ;Someday, try writing the STREAM-OUTBUFFER-OP, keyed on the predicate ; (or (memq sim:stream '(() T)) (eq sim:stream TYO)) ) (nil-defun OUSTR expr-expr (str &OPTIONAL (sim:stream OUTFILES)) ; Must check for string, if STRING-LENGTH doesn't ; (or (stringp str) (error-1 'WTA 'OUSTR str)) (do ((n (string-length str)) (i 0 (1+ i))) ((not (< i n)) () ) (tyo (*:character-to-fixnum (char str i)) sim:stream))) ;;; PUTBACK conses one of the following onto the stream's buffer-back-list: ;;; (SINGLE . item) ;;; (BUFFERKEY . #E{BUFFERKEY}( ;;; ;;; )) ;;; (STREAM . ) (nil-defun PUTBACK expr-expr (type datum stream) (prog (pbslot pb1) (caseq type ((STREAM BUFFERKEY) (and (not (eq (nil-typep datum) type)) (error-1 'WTA 'PUTBACK datum))) (SINGLE () ) (T (error-1 '|"type" unrecognized| 'PUTBACK type))) (setq pb1 (cond ((or (memq stream '(() T)) (eq stream TYO)) ;"T" stands for all ways TTY can be open 'T) ((eq (nil-typep stream) 'STREAM) stream) ((error-1 'WTA 'PUTBACK stream))) pbslot (assq pb1 sim:putback-al)) (cond ((null pbslot) (push (list pb1 (cons type datum)) sim:putback-al)) ((rplacd pbslot (cons (cons type datum) (cdr pbslot))))) (return stream))) (defun sim:stream-inbuffer-op (stream type advancep peekarg) (declare (special sim:putback-al)) (prog (pbslot pbl) (setq pbslot (assq stream sim:putback-al)) A (cond ((null (setq pbl (cdr pbslot))) (and pbslot (setq sim:putback-al (delq pbslot sim:putback-al))) (and (not (memq type '(FIXNUM CHARACTER))) (error-1 'WTA 'STREAM-BUFFER-IN-OP type)) (cond (advancep (caseq type (FIXNUM (setq data (in stream))) (CHARACTER (setq data (tyi -1 stream)) (cond ((= data -1) peekarg) ((fixnum-to-char data)))))) ((caseq type (FIXNUM (setq data (in stream)) (putback 'SINGLE data stream)) (CHARACTER (setq data(tyipeek peekarg stream))) )))) ((eq (caar pbl) 'SINGLE) (and advancep (rplacd pbslot (cdr pbl))) (setq data (cdar pbl))) ((eq (caar pbl) 'BUFFERKEY) (let ((i (vref (cdar pbl) 0)) ;See below under (mx (vref (cdar pbl 1)))) ; PUTBACK for a (declare (fixnum i mx)) ; description of (cond ((> i mx) ; buffer formats (rplacd pbslot (cdr pbl)) (go A))) (setq data (elt (vref (cdar pbl 2)) i)) (cond ((not advancep)) ((> (setq i (1+ i)) mx) (rplacd pbslot (cdr pbl))) ((vset (cdar pbl) 0 i))))) ((eq (caar pbl) 'STREAM) (setq data (sim:stream-inbuffer-op (cdar pbl) type 'T sim:unique)) (cond ((eq data sim:unique) (rplacd pbslot (cdr pbl)) (go A))) (and (not advancep) (putback 'SINGLE data (cdar pbl)))) ((error-1 '|Unknown buffer type| 'STREAM-BUFFER-IN-OP (list stream pbl)))) (and (caseq type (CHARACTER (not (characterp data))) (FIXNUM (not (fixnump data))) (T () )) (error-1 '|Wrong type object in stream| 'STREAM-BUFFER-IN-OP (list stream data))) (return data))) (comment PRINT for NIL) ;;; Bind "stream" and "princ-flag" so that sim:prin-1-ob and ;;; sim:prin-sequence can take it easy. (nil-defun PRINT nil-expr (ob &OPTIONAL sim:stream sim:princ-flag) (declare (special sim:stream sim:princ-flag)) (terpri sim:stream) (sim:prin-1-ob ob) (ouch '~/ sim:stream) *:truthity) (nil-defun PRIN1 nil-expr (ob &OPTIONAL sim:stream sim:princ-flag) (declare (special sim:stream sim:princ-flag)) (sim:prin-1-ob ob)) (nil-defun PRINC nil-expr (ob &OPTIONAL sim:stream (sim:princ-flag 'T)) (declare (special sim:stream sim:princ-flag)) (sim:prin-1-ob ob)) (defun sim:prin-sequence (ob type sep-str) (declare (special sim:stream sim:princ-flag)) (cond ((eq type 'PAIR) (prog (obs) (and (atom (setq obs ob)) (return () )) A (sim:prin-1-ob (car obs)) (cond ((or (null (cdr obs)) (eq obs (cdr obs))) ;Special check for 1 element, circular lists (return () )) ((atom (setq obs (cdr obs))) (oustr '" . " sim:stream) (sim:prin-1-ob obs) (return () ))) (ouch '~/ sim:stream) (go A))) ((prog (mx arg descendp firstp i) (declare (fixnum mx i)) (setq firstp 'T i 0) (cond ((eq type 'VECTOR) (setq descendp type) ) ((eq type 'HUNK) (setq descendp type i 1)) ((memq type '(STRING BITS)) () ) ((error-1 '|"type" incorrect| 'sim:prin-sequence type))) (setq mx (nil-length ob)) A (or (< i mx) (return () )) (cond (descendp (sim:prin-1-ob (caseq type (VECTOR (and (not firstp) (oustr sep-str sim:stream)) (vref ob i)) (HUNK (and (not firstp) (oustr sep-str sim:stream)) (cxr i ob)))) (setq firstp () )) ((eq type 'STRING) (setq arg (char ob i)) (and (not sim:princ-flag) (memq arg '(~/" ~//)) (ouch '~// sim:stream)) (ouch arg sim:stream)) ((eq type 'BITS) (ouch (*:fixnum-to-chararacter (+ 48. (bit ob i))) sim:stream))) (setq i (1+ i)) (go A))))) (defun sim:prin-1-ob (ob) (declare (special sim:stream sim:princ-flag)) (typecaseq ob (PAIR (cond ((and (eq (car ob) 'QUOTE) (pairp (cdr ob)) (null (cddr ob))) (ouch '~/' sim:stream) (sim:prin-1-ob (cadr ob))) ('T (ouch '~/( sim:stream) (sim:prin-sequence ob 'PAIR '" ") (ouch '~/) sim:stream)))) (SYMBOL (cond (sim:princ-flag (si:prinsymbol () ob sim:stream)) ('T (si:prinsymbol 'T ob sim:stream)))) ((FIXNUM FLONUM FLONUM-S) (si:prinnumber ob sim:stream)) (CHARACTER (oustr '"~//" sim:stream) (ouch ob sim:stream)) (EXTEND (let ((type (nil-typep ob))) (cond ((memq type '(BIGNUM)) (si:prinnumber ob)) ;Let MACLISP worry ('T (oustr '"#{" sim:stream) (nil-princ type sim:stream) (and (eq type 'CLASS) (ouch '~/:) (nil-princ (vref ob *:class-typep-index))) (ouch '~/} sim:stream))))) ((VECTOR VECTOR-S) (oustr '"#/(" sim:stream) (sim:prin-sequence ob 'VECTOR '" ") (ouch '~/) sim:stream)) (STRING (ouch '~/" sim:stream) (do ((i 0 (1+ i)) (mx (string-length ob))) ((not (< i mx))) (declare (fixnum i mx)) (and (= (*:character-to-fixnum (char ob i)) 34.) ;Look for imbedded " ? (ouch '~// sim:stream)) (ouch (char ob i) sim:stream)) (ouch '~/" sim:stream)) (BITS (oustr '"/#B/"" sim:stream) (do ((i 0 (1+ i)) (mx (bits-length ob))) ((not (< i mx))) (declare (fixnum i mx)) (cond ((= (bit ob i) 0) (ouch '~/0 sim:stream)) ((ouch '~/1 sim:stream)))) (ouch '~/" sim:stream)) (CONSTANT (cond ((null ob) (oustr '"()" sim:stream)) ('T (si:prinsymbol () (NEWdtp-DATUM ob))))) (SMALL-FLONUM (si:prinnumber (NEWdtp-DATUM ob))) (HUNK (oustr '"#H/(" sim:stream) (sim:prin-sequence ob 'HUNK '" . ") (oustr '" . " sim:stream) (sim:prin-1-ob (cxr 0 ob)) (ouch '~/) sim:stream)) (T (princ ob))) *:truthity ) (comment TRACE and debugging) (nil-defun TRACE (&rest names) (declare (special sim:traced-functions)) (cond (names (do ((i 0 (1+ i)) (name) (len (vector-length names))) ((not (< i len))) (cond ((not (get (setq name (vref names i)) 'function-cell)) (terpri sim:error-stream) (princ name sim:error-stream) (princ '| has no function cell, tracing anyway| sim:error-stream))) (push name sim:traced-functions) (putprop name 'T 'NIL-TRACED)) names) (sim:traced-functions))) (nil-defun UNTRACE (&rest funs) (or funs (setq funs (list-to-vector sim:traced-functions))) (do ((i 0 (1+ i)) (name) (len (vector-length funs))) ((not (< i len)) funs) (setq name (vref funs i)) (remprop name 'NIL-TRACED) (setq sim:traced-functions (delq name sim:traced-functions)))) (defun sim:cr+tab-to (n stream) (declare (special i)) (terpri stream) (do i n (1- i) (= i 0) (princ '| |))) (comment NIL-ERROR and ERROR-1) ;;; Generate an error message, then run break-loop (nil-defun ERROR nil-expr (&OPTIONAL (msg sim:unique) (loser sim:unique) chnl) (and sim:ERRSETP errset (setq sim:EPRINTP 'T)) (cond (sim:EPRINTP (terpri sim:error-stream) (princ '|;| sim:error-stream) (cond ((not (eq loser sim:unique)) (nil-prin1 loser sim:error-stream) (princ '| | sim:error-stream)))) ('T (setq msg sim:unique))) (sim:error-common msg chnl)) ;;; Generate an error message given function name, error name, and arggh (nil-defun ERROR-1 expr-expr (msg fun &OPTIONAL arg chnl) (and sim:ERRSETP errset (setq sim:EPRINTP 'T)) (cond (sim:EPRINTP (terpri sim:error-stream) (princ '|;| sim:error-stream) (nil-prin1 arg sim:error-stream () ) (princ '| | sim:error-stream) (princ (caseq msg (WTA '|Wrong type arg|) (WNA '|Wrong number of args|) (BIS '|Bad index specifications|) (BTS '|Bad type specification|) (ITM '|Internal type mismatch|) (CUL '|Can't update sequence to larger size|) (LOF '|Lost functional form|) (ILL '|Illegal LAMBDA list|) (ILF '|Illegal format|) (T msg)) sim:error-stream) (princ '|, in function | sim:error-stream)) ('T (setq fun sim:unique))) (sim:error-common fun chnl)) (defun sim:error-common (msg chnl) (prog (ob) (cond ((not (eq msg sim:unique)) (princ msg sim:error-stream) (princ '| | sim:error-stream) (terpri sim:error-stream))) (and chnl (pairp (setq ob (*break 'T chnl))) (return ob)) (cond (sim:ERRSETP (and *rset errset (nil-funcall errset () )) (*throw 'SIM:ERRSET () )) ('T (break *rset-trap)) ) (*throw () () ))) (comment BAKTRACE and TOPLEVEL functions) (nil-defun BAKTRACE nil-expr () (terpri) (mapc '(lambda (x) (prin1 x) (princ '|_ |)) sim:baktrace-info) () ) (nil-defun NIL-TOPLEVEL expr-expr () (cond ((simulationp) (terpri 'T) (princ '|Already in NIL!| 'T) (throw () () )) ('T (terpri 'T) (princ '|Entering NIL, type "(MACLISP-TOPLEVEL)" or "control-E", to enter MACLISP;| 'T) (terpri 'T) (princ '| type "(NIL-TOPLEVEL)" or "control-F" to re-enter NIL.| 'T) (setq sim:maclisp-base base base 10. sim:maclisp-ibase ibase ibase 10. *nopoint 't) (sstatus toplevel '(sim:nil-toplevel-loop)) ;The following make IF-MACLISP etc. work right. (sstatus feature NIL) (sstatus nofeature MACLISP) ;Groan!! (*throw () () )))) (nil-defun MACLISP-TOPLEVEL expr-expr () (cond ((not (simulationp)) (terpri 'T) (princ '|Already in MACLISP!| 'T) (sstatus toplevel () ) (throw () () )) ('T (terpri 'T) (princ '|Entering MACLISP, type "(NIL-TOPLEVEL)" or "control-F" to re-enter NIL;| 'T) (terpri 'T) (princ '| type "(MACLISP-TOPLEVEL)" or "control-E" to enter MACLISP.| 'T) (sstatus toplevel () ) (setq base sim:maclisp-base ibase sim:maclisp-ibase) (sstatus nofeature NIL) (sstatus feature MACLISP) (*throw 'maclisp-toplevel '*)))) (nil-defun simulationp expr-expr () (equal (status toplevel) '(sim:nil-toplevel-loop))) (defun sim:nil-toplevel-loop () (*catch 'maclisp-toplevel (do ((eof (list () )) (-) (prt '* *)) ;Internal variables (()) ;Do forever (until ^G?) (terpri) (nil-prin1 prt () () ) (tyo 32.) (terpri) (setq - (do ((form)) (()) (setq form (cond (read (funcall read eof)) ((read eof)))) (or (eq form eof) (return form)) (terpri))) (and (null read) (and (symbolp -) (and (= (tyipeek) 32.) (tyi)))) (setq * ((lambda (+) (nil-eval -)) (prog2 () + (setq + -)))))) '*) (defun sim:dump n (sstatus flush 't) ;No need to carray around LISP's pure pages ;;(sstatus feature NIL) (suspend () (cond ((= n 0) '|();ts ()|) ((arg 1)))) (terpri) (princ '|NIL version |) (princ sim:nil-version) (princ '| (simulation in MacLISP version |) (princ (status lispv)) (princ '|)|) (terpri) (setq defaultf `((DSK ,(STATUS UDIR)) NOFILE >)) (let ((file (probef `((DSK ,(STATUS HOMEDIR)) ,(STATUS USERID) /NIL)))) (cond ((not (null file)) (terpri) (princ '|Loading NIL init file from "|) (princ (namestring file)) (terpri) (load file) (terpri) (princ '|Loading completed |) (terpri)))) (nil-toplevel) '*)  .TITLE SLINK -- Set up the SLINK .INSERT NIL$MAXROHEADER .SAVE VM$FILE_INFO STRING PURE=T .LONG 39 STRING PURE=T VM$SLINK .ALIGN PAGE .LONG 2340 VM$INIT_SLINK:: QT$K_SLINK==.+TC$K_VECTOR VM$BLINTZ .ALIGN PAGE .LONG 328 VM$INIT_BLINTZ:: QT$K_BLINTZ==.+TC$K_VECTOR .PSECT VM$SLINK .BLKL 25 .LONG 1. ; CL$TAB_TYPE_BIT .GLOBAL CL$TAB_TYPE_BIT .LONG 2. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 4. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 8. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 16. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 32. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 64. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 128. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 256. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 512. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 1024. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 2048. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 4096. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 8192. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 16384. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 32768. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 65536. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 131072. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 262144. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 524288. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 1048576. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 2097152. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 4194304. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 8388608. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 16777216. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 33554432. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 67108864. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 134217728. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 268435456. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 536870912. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 1073741824. ; ... .GLOBAL CL$TAB_TYPE_BIT .LONG 2147483648. ; ... .GLOBAL CL$TAB_TYPE_BIT .BLKL 3 .LONG MS$ALLOC_PGS ; CL$MS_ALLOC_PGS .GLOBAL CL$MS_ALLOC_PGS .BLKL 13 .LONG VM$K_TMP_IOBUF ; CL$VM_TMP_IOBUF .GLOBAL CL$VM_TMP_IOBUF .LONG 0. ; CL$TM_OUTCHAN .GLOBAL CL$TM_OUTCHAN .LONG VM$K_STR_HASH2 ; CL$VM_STR_HASH2 .GLOBAL CL$VM_STR_HASH2 .LONG VM$K_STR_HASH1 ; CL$VM_STR_HASH1 .GLOBAL CL$VM_STR_HASH1 .LONG 0. ; CL$TM_SYM_SPACE .GLOBAL CL$TM_SYM_SPACE .LONG 0. ; CL$TM_SYM_LIST .GLOBAL CL$TM_SYM_LIST .LONG 0. ; CL$TM_INHIB_INT .GLOBAL CL$TM_INHIB_INT .LONG 0. ; CL$TM_INHIB_GC .GLOBAL CL$TM_INHIB_GC .LONG QT$K_UNBOUND_V ; CL$QC_UNBOUND_V .GLOBAL CL$QC_UNBOUND_V .LONG QT$K_UNBOUND_F ; CL$QC_UNBOUND_F .GLOBAL CL$QC_UNBOUND_F .LONG 0. ; CL$TM_STK_DIRTY .GLOBAL CL$TM_STK_DIRTY .LONG QS$K_LAST_SFS ; CL$QS_LAST_SFS .GLOBAL CL$QS_LAST_SFS .LONG QS$K_FIRST_SFS ; CL$QS_FIRST_SFS .GLOBAL CL$QS_FIRST_SFS .BLKL 4 .LONG QT$K_AFM_MARKER+<0@2> ; CL$TAB_AFM_MARK .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<1@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<2@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<3@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<4@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<5@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<6@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<7@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<8@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<9@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<10@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<11@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<12@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<13@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<14@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<15@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<16@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<17@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<18@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<19@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<20@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<21@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<22@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<23@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<24@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<25@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<26@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<27@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<28@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<29@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<30@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<31@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<32@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<33@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<34@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<35@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<36@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<37@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<38@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<39@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<40@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<41@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<42@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<43@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<44@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<45@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<46@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<47@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<48@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<49@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<50@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<51@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<52@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<53@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<54@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<55@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<56@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<57@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<58@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<59@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<60@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<61@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<62@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<63@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<64@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<65@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<66@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<67@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<68@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<69@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<70@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<71@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<72@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<73@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<74@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<75@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<76@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<77@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<78@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<79@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<80@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<81@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<82@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<83@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<84@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<85@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<86@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<87@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<88@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<89@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<90@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<91@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<92@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<93@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<94@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<95@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<96@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<97@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<98@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<99@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<100@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<101@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<102@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<103@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<104@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<105@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<106@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<107@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<108@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<109@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<110@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<111@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<112@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<113@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<114@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<115@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<116@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<117@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<118@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<119@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<120@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<121@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<122@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<123@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<124@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<125@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<126@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<127@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<128@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<129@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<130@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<131@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<132@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<133@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<134@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<135@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<136@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<137@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<138@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<139@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<140@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<141@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<142@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<143@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<144@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<145@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<146@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<147@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<148@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<149@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<150@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<151@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<152@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<153@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<154@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<155@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<156@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<157@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<158@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<159@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<160@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<161@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<162@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<163@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<164@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<165@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<166@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<167@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<168@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<169@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<170@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<171@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<172@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<173@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<174@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<175@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<176@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<177@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<178@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<179@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<180@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<181@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<182@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<183@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<184@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<185@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<186@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<187@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<188@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<189@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<190@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<191@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<192@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<193@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<194@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<195@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<196@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<197@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<198@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<199@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<200@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<201@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<202@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<203@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<204@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<205@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<206@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<207@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<208@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<209@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<210@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<211@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<212@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<213@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<214@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<215@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<216@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<217@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<218@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<219@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<220@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<221@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<222@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<223@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<224@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<225@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<226@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<227@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<228@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<229@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<230@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<231@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<232@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<233@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<234@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<235@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<236@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<237@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<238@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<239@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<240@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<241@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<242@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<243@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<244@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<245@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<246@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<247@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<248@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<249@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<250@2> ; ... .GLOBAL CL$TAB_AFM_MARK .LONG QT$K_AFM_MARKER+<251@2> ; ... .GLOBAL CL$TAB_AFM_MARK .BLKL 1 .LONG 0. ; CL$TM_POLLP .GLOBAL CL$TM_POLLP .LONG 0. ; CL$TM_HEAPEDGE .GLOBAL CL$TM_HEAPEDGE .LONG 0. ; CL$TM_HEAP .GLOBAL CL$TM_HEAP .LONG PHP$NULPAGE ; CL$VM_NULPAGADR .GLOBAL CL$VM_NULPAGADR .LONG TCU$K_VECTOR ; CL$TCU_VECTOR .GLOBAL CL$TCU_VECTOR .LONG 2147483648. ; CL$TCM_SGNBIT .GLOBAL CL$TCM_SGNBIT .LONG 2147483651. ; CL$TCM_VECT_ADR .GLOBAL CL$TCM_VECT_ADR .LONG 4294967264. ; CL$TCM_LO_TYPEC .GLOBAL CL$TCM_LO_TYPEC .LONG 536870908. ; CL$TCM_TYPECODE .GLOBAL CL$TCM_TYPECODE .LONG 3758096387. ; CL$TCM_ADDRESS .GLOBAL CL$TCM_ADDRESS .LONG TC$K_PAIR ; CL$TC_PAIR .GLOBAL CL$TC_PAIR .LONG TCU$K_BITS ; CL$TCU_BITS .GLOBAL CL$TCU_BITS .LONG QT$K_DIRT_MARK ; CL$QC_DIRT_MARK .GLOBAL CL$QC_DIRT_MARK .LONG QT$K_CCFRAME ; CL$QC_CCFRAME .GLOBAL CL$QC_CCFRAME .LONG TCU$K_SEQUENCE ; CL$TCU_SEQUENCE .GLOBAL CL$TCU_SEQUENCE .LONG TCU$K_FIX ; CL$TCU_FIX .GLOBAL CL$TCU_FIX .LONG QT$K_TRUTH ; CL$QC_TRUTH .GLOBAL CL$QC_TRUTH .LONG TCU$K_FLONUM ; CL$TCU_FLONUM .GLOBAL CL$TCU_FLONUM .BLKL 5 .LONG MS$SPECBIND ; CL$MS_SPECBIND .GLOBAL CL$MS_SPECBIND .LONG MS$VBIND ; CL$MS_VBIND .GLOBAL CL$MS_VBIND .LONG MS$UNBIND ; CL$MS_UNBIND .GLOBAL CL$MS_UNBIND .LONG MS$IAPPLY ; CL$MS_IAPPLY .GLOBAL CL$MS_IAPPLY .LONG MS$IFUNCALL ; CL$MS_IFUNCALL .GLOBAL CL$MS_IFUNCALL .LONG MS$ISEND ; CL$MS_ISEND .GLOBAL CL$MS_ISEND .LONG MS$INTERRUPT ; CL$MS_INTERRUPT .GLOBAL CL$MS_INTERRUPT .LONG MS$THROW ; CL$MS_THROW .GLOBAL CL$MS_THROW .LONG QT$K_NULL ; CL$QC_NULL .GLOBAL CL$QC_NULL .BLKL 1 .LONG MS$CAR ; CL$MS_CAR .GLOBAL CL$MS_CAR .LONG MS$CDR ; CL$MS_CDR .GLOBAL CL$MS_CDR .LONG MS$RPLACA ; CL$MS_RPLACA .GLOBAL CL$MS_RPLACA .LONG MS$RPLACD ; CL$MS_RPLACD .GLOBAL CL$MS_RPLACD .LONG MS$C...R ; CL$MS_C...R .GLOBAL CL$MS_C...R .LONG MS$ELT ; CL$MS_ELT .GLOBAL CL$MS_ELT .LONG MS$SETELT ; CL$MS_SETELT .GLOBAL CL$MS_SETELT .LONG MS$VREF ; CL$MS_VREF .GLOBAL CL$MS_VREF .LONG MS$VSET ; CL$MS_VSET .GLOBAL CL$MS_VSET .LONG MS$CHAR ; CL$MS_CHAR .GLOBAL CL$MS_CHAR .LONG MS$RPLACHAR ; CL$MS_RPLACHAR .GLOBAL CL$MS_RPLACHAR .LONG MS$BIT ; CL$MS_BIT .GLOBAL CL$MS_BIT .LONG MS$RPLACBIT ; CL$MS_RPLACBIT .GLOBAL CL$MS_RPLACBIT .LONG MS$NPUSH ; CL$MS_NPUSH .GLOBAL CL$MS_NPUSH .LONG MS$0PUSH ; CL$MS_0PUSH .GLOBAL CL$MS_0PUSH .LONG MS$VPUSH ; CL$MS_VPUSH .GLOBAL CL$MS_VPUSH .LONG MS$CONS ; CL$MS_CONS .GLOBAL CL$MS_CONS .LONG MS$CONSI ; CL$MS_CONSI .GLOBAL CL$MS_CONSI .LONG MS$CONSN ; CL$MS_CONSN .GLOBAL CL$MS_CONSN .LONG MS$LCONS ; CL$MS_LCONS .GLOBAL CL$MS_LCONS .LONG MS$VECT_CONS ; CL$MS_VECT_CONS .GLOBAL CL$MS_VECT_CONS .LONG MS$STR_CONS ; CL$MS_STR_CONS .GLOBAL CL$MS_STR_CONS .LONG MS$BITS_CONS ; CL$MS_BITS_CONS .GLOBAL CL$MS_BITS_CONS .LONG MS$EXT_CONS ; CL$MS_EXT_CONS .GLOBAL CL$MS_EXT_CONS .LONG MS$NTH ; CL$MS_NTH .GLOBAL CL$MS_NTH .LONG MS$NTHCDR ; CL$MS_NTHCDR .GLOBAL CL$MS_NTHCDR .LONG MS$HNDL_OP ; CL$MS_HNDL_OP .GLOBAL CL$MS_HNDL_OP .LONG MS$HDNL_OP1 ; CL$MS_HDNL_OP1 .GLOBAL CL$MS_HDNL_OP1 .LONG MS$HNDL_RS ; CL$MS_HNDL_RS .GLOBAL CL$MS_HNDL_RS .LONG MS$HNDL_OPRS ; CL$MS_HNDL_OPRS .GLOBAL CL$MS_HNDL_OPRS .LONG MS$BOUNDP ; CL$MS_BOUNDP .GLOBAL CL$MS_BOUNDP .LONG MS$FBOUNDP ; CL$MS_FBOUNDP .GLOBAL CL$MS_FBOUNDP .LONG MS$SYMEVAL ; CL$MS_SYMEVAL .GLOBAL CL$MS_SYMEVAL .LONG MS$FSYMEVAL ; CL$MS_FSYMEVAL .GLOBAL CL$MS_FSYMEVAL .LONG MS$APPLYSUBR ; CL$MS_APPLYSUBR .GLOBAL CL$MS_APPLYSUBR .LONG MS$SYMCONS ; CL$MS_SYMCONS .GLOBAL CL$MS_SYMCONS .LONG MS$FXTOFL ; CL$MS_FXTOFL .GLOBAL CL$MS_FXTOFL .LONG MS$GET ; CL$MS_GET .GLOBAL CL$MS_GET .LONG MS$LENGTH ; CL$MS_LENGTH .GLOBAL CL$MS_LENGTH .LONG MS$LAST ; CL$MS_LAST .GLOBAL CL$MS_LAST .LONG MS$ASSQ ; CL$MS_ASSQ .GLOBAL CL$MS_ASSQ .LONG MS$MEMQ ; CL$MS_MEMQ .GLOBAL CL$MS_MEMQ .LONG MS$DELQ ; CL$MS_DELQ .GLOBAL CL$MS_DELQ .LONG MS$RASSQ ; CL$MS_RASSQ .GLOBAL CL$MS_RASSQ .LONG MS$POSASSQ ; CL$MS_POSASSQ .GLOBAL CL$MS_POSASSQ .LONG MS$MEMASSQ ; CL$MS_MEMASSQ .GLOBAL CL$MS_MEMASSQ .LONG MS$STK_DIRT ; CL$MS_STK_DIRT .GLOBAL CL$MS_STK_DIRT .LONG MS$STK_CLEAN ; CL$MS_STK_CLEAN .GLOBAL CL$MS_STK_CLEAN .LONG MS$REST_DIRT ; CL$MS_REST_DIRT .GLOBAL CL$MS_REST_DIRT .LONG MS$SFLOAT ; CL$MS_SFLOAT .GLOBAL CL$MS_SFLOAT .BLKL 3 .LONG MS$IUDF_ERR ; CL$MS_IUDF_ERR .GLOBAL CL$MS_IUDF_ERR .LONG MS$IMNA_ERR ; CL$MS_IMNA_ERR .GLOBAL CL$MS_IMNA_ERR .LONG MS$WNA_ERR ; CL$MS_WNA_ERR .GLOBAL CL$MS_WNA_ERR .LONG MS$WTA_ERR ; CL$MS_WTA_ERR .GLOBAL CL$MS_WTA_ERR .LONG MS$PDLDPTH ; CL$MS_PDLDPTH .GLOBAL CL$MS_PDLDPTH .LONG MS$SYMTABIDX ; CL$MS_SYMTABIDX .GLOBAL CL$MS_SYMTABIDX .LONG MS$STR_HASH ; CL$MS_STR_HASH .GLOBAL CL$MS_STR_HASH .LONG MS$FIND_SLI ; CL$MS_FIND_SLI .GLOBAL CL$MS_FIND_SLI .LONG MS$FIND_PRVC ; CL$MS_FIND_PRVC .GLOBAL CL$MS_FIND_PRVC .LONG MS$L_LENGTH ; CL$MS_L_LENGTH .GLOBAL CL$MS_L_LENGTH .LONG MS$L_SUBSEQ ; CL$MS_L_SUBSEQ .GLOBAL CL$MS_L_SUBSEQ .LONG MS$V_SUBSEQ ; CL$MS_V_SUBSEQ .GLOBAL CL$MS_V_SUBSEQ .LONG MS$S_SUBSEQ ; CL$MS_S_SUBSEQ .GLOBAL CL$MS_S_SUBSEQ .LONG MS$B_SUBSEQ ; CL$MS_B_SUBSEQ .GLOBAL CL$MS_B_SUBSEQ .LONG MS$L_FILL ; CL$MS_L_FILL .GLOBAL CL$MS_L_FILL .LONG MS$V_FILL ; CL$MS_V_FILL .GLOBAL CL$MS_V_FILL .LONG MS$S_FILL ; CL$MS_S_FILL .GLOBAL CL$MS_S_FILL .LONG MS$B_FILL ; CL$MS_B_FILL .GLOBAL CL$MS_B_FILL .LONG MS$L_REPLACE ; CL$MS_L_REPLACE .GLOBAL CL$MS_L_REPLACE .LONG MS$V_REPLACE ; CL$MS_V_REPLACE .GLOBAL CL$MS_V_REPLACE .LONG MS$S_REPLACE ; CL$MS_S_REPLACE .GLOBAL CL$MS_S_REPLACE .LONG MS$B_REPLACE ; CL$MS_B_REPLACE .GLOBAL CL$MS_B_REPLACE .LONG MS$L_POSQ ; CL$MS_L_POSQ .GLOBAL CL$MS_L_POSQ .LONG MS$V_POSQ ; CL$MS_V_POSQ .GLOBAL CL$MS_V_POSQ .LONG MS$S_POSQ ; CL$MS_S_POSQ .GLOBAL CL$MS_S_POSQ .LONG MS$B_POSQ ; CL$MS_B_POSQ .GLOBAL CL$MS_B_POSQ .LONG MS$L_SEARQ ; CL$MS_L_SEARQ .GLOBAL CL$MS_L_SEARQ .LONG MS$V_SEARQ ; CL$MS_V_SEARQ .GLOBAL CL$MS_V_SEARQ .LONG MS$S_SEARQ ; CL$MS_S_SEARQ .GLOBAL CL$MS_S_SEARQ .LONG MS$B_SEARQ ; CL$MS_B_SEARQ .GLOBAL CL$MS_B_SEARQ .LONG MS$L_MISMATQ ; CL$MS_L_MISMATQ .GLOBAL CL$MS_L_MISMATQ .LONG MS$V_MISMATQ ; CL$MS_V_MISMATQ .GLOBAL CL$MS_V_MISMATQ .LONG MS$S_MISMATQ ; CL$MS_S_MISMATQ .GLOBAL CL$MS_S_MISMATQ .LONG MS$B_MISMATQ ; CL$MS_B_MISMATQ .GLOBAL CL$MS_B_MISMATQ .LONG MS$L_SKIPQ ; CL$MS_L_SKIPQ .GLOBAL CL$MS_L_SKIPQ .LONG MS$V_SKIPQ ; CL$MS_V_SKIPQ .GLOBAL CL$MS_V_SKIPQ .LONG MS$S_SKIPQ ; CL$MS_S_SKIPQ .GLOBAL CL$MS_S_SKIPQ .LONG MS$B_SKIPQ ; CL$MS_B_SKIPQ .GLOBAL CL$MS_B_SKIPQ .LONG MS$L.SUBSEQ ; CL$MS_L.SUBSEQ .GLOBAL CL$MS_L.SUBSEQ .LONG MS$V.SUBSEQ ; CL$MS_V.SUBSEQ .GLOBAL CL$MS_V.SUBSEQ .LONG MS$S.SUBSEQ ; CL$MS_S.SUBSEQ .GLOBAL CL$MS_S.SUBSEQ .LONG MS$B.SUBSEQ ; CL$MS_B.SUBSEQ .GLOBAL CL$MS_B.SUBSEQ .LONG MS$L.FILL ; CL$MS_L.FILL .GLOBAL CL$MS_L.FILL .LONG MS$V.FILL ; CL$MS_V.FILL .GLOBAL CL$MS_V.FILL .LONG MS$S.FILL ; CL$MS_S.FILL .GLOBAL CL$MS_S.FILL .LONG MS$B.FILL ; CL$MS_B.FILL .GLOBAL CL$MS_B.FILL .LONG MS$L.REPLACE ; CL$MS_L.REPLACE .GLOBAL CL$MS_L.REPLACE .LONG MS$V.REPLACE ; CL$MS_V.REPLACE .GLOBAL CL$MS_V.REPLACE .LONG MS$S.REPLACE ; CL$MS_S.REPLACE .GLOBAL CL$MS_S.REPLACE .LONG MS$B.REPLACE ; CL$MS_B.REPLACE .GLOBAL CL$MS_B.REPLACE .LONG MS$L.POSQ ; CL$MS_L.POSQ .GLOBAL CL$MS_L.POSQ .LONG MS$V.POSQ ; CL$MS_V.POSQ .GLOBAL CL$MS_V.POSQ .LONG MS$S.POSQ ; CL$MS_S.POSQ .GLOBAL CL$MS_S.POSQ .LONG MS$B.POSQ ; CL$MS_B.POSQ .GLOBAL CL$MS_B.POSQ .LONG MS$L.SEARQ ; CL$MS_L.SEARQ .GLOBAL CL$MS_L.SEARQ .LONG MS$V.SEARQ ; CL$MS_V.SEARQ .GLOBAL CL$MS_V.SEARQ .LONG MS$S.SEARQ ; CL$MS_S.SEARQ .GLOBAL CL$MS_S.SEARQ .LONG MS$B.SEARQ ; CL$MS_B.SEARQ .GLOBAL CL$MS_B.SEARQ .LONG MS$L.MISMATQ ; CL$MS_L.MISMATQ .GLOBAL CL$MS_L.MISMATQ .LONG MS$V.MISMATQ ; CL$MS_V.MISMATQ .GLOBAL CL$MS_V.MISMATQ .LONG MS$S.MISMATQ ; CL$MS_S.MISMATQ .GLOBAL CL$MS_S.MISMATQ .LONG MS$B.MISMATQ ; CL$MS_B.MISMATQ .GLOBAL CL$MS_B.MISMATQ .LONG MS$L.SKIPQ ; CL$MS_L.SKIPQ .GLOBAL CL$MS_L.SKIPQ .LONG MS$V.SKIPQ ; CL$MS_V.SKIPQ .GLOBAL CL$MS_V.SKIPQ .LONG MS$S.SKIPQ ; CL$MS_S.SKIPQ .GLOBAL CL$MS_S.SKIPQ .LONG MS$B.SKIPQ ; CL$MS_B.SKIPQ .GLOBAL CL$MS_B.SKIPQ .LONG MS$S.EQUAL ; CL$MS_S.EQUAL .GLOBAL CL$MS_S.EQUAL .BLKL 6 .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:APPLY .GLOBAL SL$SFL_APPLY, SL$SFC_APPLY .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=APPLY, - CELL_INDEX=<<3@24>+SL$SFL_APPLY> .RESTORE .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:CATCH .GLOBAL SL$SFL_CATCH, SL$SFC_CATCH .SAVE VM$BLINTZ .LONG 0 .LONG QT$K_CATCH .RESTORE .LONG .+4 .LONG SB$RINTERN ; SI:RINTERN .GLOBAL SL$SFL_RINTERN, SL$SFC_RINTERN .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=RINTERN, - CELL_INDEX=<<3@24>+SL$SFL_RINTERN> .RESTORE .LONG .+4 .LONG SB$PKG_FIND ; SI:RPKG-FIND-PACKAGE .GLOBAL SL$SFL_PKG_FIND, SL$SFC_PKG_FIND .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=PKG_FIND, - CELL_INDEX=<<3@24>+SL$SFL_PKG_FIND> .RESTORE .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:PKG-CREATE-PACKAGE .GLOBAL SL$SFL_PKG_CREA, SL$SFC_PKG_CREA .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=PKG_CREA, - CELL_INDEX=<<3@24>+SL$SFL_PKG_CREA> .RESTORE .LONG .+4 .LONG SB$I_INCH ; GLOBAL:INCH .GLOBAL SL$SFL_INCH, SL$SFC_INCH .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=INCH, - CELL_INDEX=<<3@24>+SL$SFL_INCH> .RESTORE .LONG .+4 .LONG SB$I_OUCH ; GLOBAL:OUCH .GLOBAL SL$SFL_OUCH, SL$SFC_OUCH .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=OUCH, - CELL_INDEX=<<3@24>+SL$SFL_OUCH> .RESTORE .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:CERROR .GLOBAL SL$SFL_CERROR, SL$SFC_CERROR .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=CERROR, - CELL_INDEX=<<3@24>+SL$SFL_CERROR> .RESTORE .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:FERROR .GLOBAL SL$SFL_FERROR, SL$SFC_FERROR .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=FERROR, - CELL_INDEX=<<3@24>+SL$SFL_FERROR> .RESTORE .LONG .+4 .LONG SB$UNDEFINED ; GLOBAL:EVAL .GLOBAL SL$SFL_EVAL, SL$SFC_EVAL .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=EVAL, - CELL_INDEX=<<3@24>+SL$SFL_EVAL> .RESTORE .BLKL 16 .LONG .+4 .LONG QT$K_MINI_SUB ; SI:MINI-SUBR-TABLE .GLOBAL SL$SVL_MINI_SUB, SL$SVC_MINI_SUB .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=MINI_SUB, - CELL_INDEX=<<1@24>+SL$SVL_MINI_SUB> .RESTORE .LONG .+4 .LONG QT$K_CONST_TB ; SI:CONSTANT-NAME-TABLE .GLOBAL SL$SVL_CONST_TB, SL$SVC_CONST_TB .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=CONST_TB, - CELL_INDEX=<<1@24>+SL$SVL_CONST_TB> .RESTORE .LONG .+4 .LONG QT$K_GLBL_PKG ; GLOBAL:PACKAGE .GLOBAL SL$SVL_PACKAGE, SL$SVC_PACKAGE .SAVE VM$BLINTZ .LONG 0 SYMBOL GLOBAL LABEL=PACKAGE, - CELL_INDEX=<<1@24>+SL$SVL_PACKAGE> .RESTORE .LONG .+4 .LONG QT$K_GLBL_PKG ; SI:GLOBAL-PACKAGE .GLOBAL SL$SVL_GLBL_PKG, SL$SVC_GLBL_PKG .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=GLBL_PKG, - CELL_INDEX=<<1@24>+SL$SVL_GLBL_PKG> .RESTORE .LONG .+4 .LONG QT$K_USER_PKG ; SI:USER-PACKAGE .GLOBAL SL$SVL_USER_PKG, SL$SVC_USER_PKG .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=USER_PKG, - CELL_INDEX=<<1@24>+SL$SVL_USER_PKG> .RESTORE .LONG .+4 .LONG QT$K_ERR_STR ; SI:ERROR-STRINGS .GLOBAL SL$SVL_ERR_STR, SL$SVC_ERR_STR .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=ERR_STR, - CELL_INDEX=<<1@24>+SL$SVL_ERR_STR> .RESTORE .BLKL 16 .LONG .+4 .LONG 0. ; SI:SPECPDL .GLOBAL SL$SVL_SPECPDL, SL$SVC_SPECPDL .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SPECPDL, - CELL_INDEX=<<1@24>+SL$SVL_SPECPDL> .RESTORE .LONG .+4 .LONG 0. ; SI:SPECPDL-ORIGIN .GLOBAL SL$SVL_SPDLOR, SL$SVC_SPDLOR .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SPDLOR, - CELL_INDEX=<<1@24>+SL$SVL_SPDLOR> .RESTORE .LONG .+4 .LONG 0. ; SI:SPECPDL-TOP .GLOBAL SL$SVL_SPDLTP, SL$SVC_SPDLTP .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SPDLTP, - CELL_INDEX=<<1@24>+SL$SVL_SPDLTP> .RESTORE .LONG .+4 .LONG 0. ; SI:SPECPDL-FRONTIER .GLOBAL SL$SVL_SPDLFR, SL$SVC_SPDLFR .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SPDLFR, - CELL_INDEX=<<1@24>+SL$SVL_SPDLFR> .RESTORE .LONG .+4 .LONG QT$K_BLINTZ ; SI:BLINTZ-VECTOR .GLOBAL SL$SVL_BLINTZ, SL$SVC_BLINTZ .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=BLINTZ, - CELL_INDEX=<<1@24>+SL$SVL_BLINTZ> .RESTORE .LONG .+4 .LONG QT$K_SLINK ; SI:SLINK-VECTOR .GLOBAL SL$SVL_SLINK, SL$SVC_SLINK .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SLINK, - CELL_INDEX=<<1@24>+SL$SVL_SLINK> .RESTORE .LONG .+4 .LONG VM$K_CLINK_SIZE ; SI:CLINK-SIZE .GLOBAL SL$SVL_CL_SIZE, SL$SVC_CL_SIZE .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=CL_SIZE, - CELL_INDEX=<<1@24>+SL$SVL_CL_SIZE> .RESTORE .LONG .+4 .LONG VM$K_SLP_OFF ; SI:SLP-OFFSET .GLOBAL SL$SVL_SLP_OFF, SL$SVC_SLP_OFF .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SLP_OFF, - CELL_INDEX=<<1@24>+SL$SVL_SLP_OFF> .RESTORE .LONG .+4 .LONG VM$K_SLINK_SIZE ; SI:SLINK-SIZE .GLOBAL SL$SVL_SL_SIZE, SL$SVC_SL_SIZE .SAVE VM$BLINTZ .LONG 0 SYMBOL SI LABEL=SL_SIZE, - CELL_INDEX=<<1@24>+SL$SVL_SL_SIZE> .RESTORE .RESTORE VM$K_SLINK_SIZE==585 VM$K_BLINTZ_SIZ==82 .GLOBAL VM$K_SLINK_SIZE, VM$K_BLINTZ_SIZ .END ;;; NCOMPL -*-LISP-*- ;;; ******************************************************************* ;;; *********** NIL ***** NIL Compiler ******************************** ;;; ******************************************************************* ;;; ***** (C) Copyright 1980 Massachusetts Institute of Technology **** ;;; ********* This is a Read-Only file! (All writes reserved) ********* ;;; ******************************************************************* (include ((NILSRC) MACROS)) ; includes the full definitions of ; "GET-MACRO-DEF", "MACRO-NIL-EXPAND", and all MAP series (herald NCOMPLR /50) (globalize "SYMBOLIC-CONSTANT" ) (comment DEFVST definitions) (defvst NODE funform arglist original mode ) ;;; ########## Sometime add these: (cnt 0) effslist complexity ;General output of phase 1 is a NODE ; For LAMBDA's, the arglist has a LAMARGL structure as first element ; For QUOTE's, the arglist consists of the COMP and the LOC structures ; necessary for this quotified frob. (defvst COMP kind data (cnt 0) ) ;General output of phase 2 is a COMP ;COMP-kind is among QUOTE, VAR, CARCDR, COMP (defvst LOC kind data offset) ;General specification of a location in the virtual machine - output ; of the LOCATE function, which is applied to the output of phase 2. ;LOC-kind is among 1) QUOTE, ; 2) REG, @REG, CLINK ; 3) SPECIAL, FUNCTION, LOCAL, LFUNCTION ;LOC-data is the frob itself for QUOTEs, the register name for REG and @REG, ; and the variable name for the others. (defvst VAR srcnam ;the "name", a symbol, as it occurs in the source code srctype ;(ARG ) where is among ; &REQUIRED &OPTIONAL &REST and is position ; in the lambda-list ;(LAMBDA ) ;(FREE ) specialp ; either (), meaning ... homeloc ;#(REG AP ) or #(REG FP ) ; where is the Q index off AP ;#(SPECIAL ) or #(LOCAL ) mode) (defvst FUNFORM name (type 'SUBR) ;or MSUBR, or CARCDR, or SPECIAL-FORM scrwr ;Source Code ReWrite Rule (p1fun 'P1-ALL-ARGS) (p2fun 'COMP-CALL) (p2fun-br 'COMP-FOR-BR) argspectrum data ) (defvst ARGSPECTRUM required (optional 0) (rest 0)) ;number of each kind ;The following structures are used as the first "argument" ; to a LAMBDA. The variable *LEXICAL-CONTOURS* is a chain of such ; structures. (defvst LAMARGL lamvars ;list of VAR structs for all lambda vars specvars ;list of VAR structs for all special lambda vars slotlevel body ;PROGNification of the lambda body ) (defvst PROGL name ;name of the original prog (defaultly ()) tags ;a list of the PTAGs exittag ;assembly tag for end of the PROG body (for RETURN) ; backlink slotlevel ;`(,*slotlevel* . ,(car *lexical-contours*)) ) (defvst PTAG sourcename ;name in the source code tagname ;assembly tag progl ;for the containing prog slotlevel ;`(,*slotlevel* . ,(car *lexical-contours*)) ) ;Typical FUNFORMs are: ; #{FUNFORM name COND type SPECIAL-FORM p1fun P1COND p2fun COMCOND} ; #{FUNFORM name PUTBACK type SUBR p1fun P1-ALL-ARGS p2fun COMSUBR ; argspectrum #{ARGSPECTRUM required 3}} ; #{FUNFORM name CAR type CARCDR srcwr CARCDR-expand ; p1fun P1-ALL-ARGS p2fun LCODE-OUT p2fun-br COMP-FOR-BR ; argspectrum #{ARGSPECTRUM required 1} ; data ((VALUE-LCODE ...)) } ; #{FUNFORM name CADDR type CARCDR srcwr CARCDR-expand ; ... argspectrum #{ARGSPECTRUM required 1} } ; #{FUNFORM name BITS-MISMATCH type MSUBR srcwr CANONICALIZE-name ; p1fun P1-ALL-ARGS p2fun COM-MSUBR-2R* ; argspectrum #{ARGSPECTRUM required 2 optional 3} } ; #{FUNFORM name LAMBDA type SPECIAL-FORM p1fun P1LAM p2fun COMLAMAP} ; The node for a lambda application would be like ; #( #(LAMBDA ...) #(( ...) ; arg1 ; arg2 ...) ; () ; ...) ; The DATA field is an alist, whose keys are among ; RENAME for changing names, like "NOT" ==> "NULL" ; MSUBR-NAME to give MS$L.REPLACE for "LIST-REPLACE" ; VALUE-LCODE stuff open-codable for value from a "template" ; BOOLE-LCODE stuff open-codable for condition code ... ; CARCDR composed (composite) carcdr form (COMMENT global SPECIAL declarations and INITIALIZE) (DECLARE (*EXPR CAPTURE-FREE-VARIABLE?) ;; The following are "internal" functions, just to capitalize on the ;; FUNFORM sequenceing: (*EXPR CL:create-typeless-null CL:prog-seq ) ) (DECLARE ;; Declarations for special variables from user-level features (SPECIAL COMPILER-STATE TOPFN QUIT-ON-ERROR GAG-ERRBREAKS SPECIALS ) ;; Declarations for special variables for maclisp-style I/O features (SPECIAL YESWARNTTY CMSGFILES ) (SPECIAL COBARRAY SOBARRAY CREADTABLE SREADTABLE) ) (DECLARE ;; Declarations for internal compiler constants and tables ;; Items with names beginning "CL:. . ." are internal markers, and ;; must not conflict with any system or user symbol usage. (SPECIAL CL:destination CL:quote-funform *:truth CL:truthnode CL:nilnode CL:typeless-nilnode CL:unspecified) ;= *:truth ;simply holds #T ;= CL:truthnode ;holds a p1-output quantity for #T ;= CL:nilnode ;holds a p1-output quantity for the nullist ;= CL:typeless-nilnode ;same as nilnode, but "numeric type" is unspecified ;= LEXICAL-CONTOURS ;each entry is a LAMARGL structure ; ; corresponding to one contour (SPECIAL SPECIALVARS IGNOREVARS SYMBOLICVARS FILEFUNFORMS LOCAL-MODES 1-REQ-ARG LEXICAL-CONTOURS CAPTURE-FREE-VARIABLE? ) (SPECIAL LIST-FROBBL-LENGTH) ) (defun INITIALIZE () (setq SPECIALVARS () IGNOREVARS () SYMBOLICVARS () FILEFUNFORMS () LOCAL-MODES () 1-REQ-ARG () LEXICAL-CONTOURS () CAPTURE-FREE-VARIABLE? () ) (setq LIST-FROBBL-LENGTH 3) (setq SPECIALS () TOPFN () QUIT-ON-ERROR () ;Damn it!!! Don't set this until it's production! GAG-ERRBREAKS () COMPILER-STATE 'TOPLEVEL) ;######## What to do about OBARRAY versus PACKAGE (setq SOBARRAY (setq COBARRAY OBARRAY) SREADTABLE (setq CREADTABLE READTABLE)) (setq YESWARNTTY 'T CMSGFILES MSGFILES) (setup-all-funforms) ) (COMMENT LOCAL COMPILER MACROS) (declare (setq DEFMACRO-FOR-COMPILING () DEFMACRO-CHECK-ARGS 'T DEFMACRO-DISPLACE-CALL () )) ;??(defmacro /2^N-P (n) `(ZEROP (BOOLE 4 ,n (- ,n)))) (defmacro PUSHL (x l) ;"PUSH" onto a (cond ((atom l) `(RPLACD ,l (CONS ,x (CDR ,l)))) ((let ((item (gensym)) (pair (gensym))) ; "list" cell `(LET ((,item ,x) (,pair ,l)) (RPLACD ,pair (CONS ,item (CDR ,pair)))))))) (defmacro POPL (l) (cond ((atom l) `(RPLACD ,l (CDDR ,l))) ((let ((pair (gensym))) `(LET ((,pair ,l)) (RPLACD ,pair (CDDR ,pair))))))) (defmacro BARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'BARF ,a1 ,a2)) (defmacro DBARF (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'DATA ,a1 ,a2)) (defmacro WARN (item msg &OPTIONAL a1 a2) `(MSOUT ,item ',msg 'WARN ,a1 ,a2)) (defmacro PDERR (item msg) `(MSOUT ,item ',msg 'ERRFL 4 6)) ;??(defmacro P1HHCTB (node) ; `(BARF ,node |You really can't get there from here - P1HHCTB|)) (declare (setq DEFMACRO-FOR-COMPILING 'T DEFMACRO-CHECK-ARGS 'T DEFMACRO-DISPLACE-CALL () )) ;;P/.5 and P1 were here; moved to RLB;COM (comment varied P1 functions) (defun p1-illfun (x) (pderr x |Illegal functional specifier|) cl:typeless-nilnode) (defun P1-QUOTE (ff x) (P1-CONS-A-QUOTE (cadr x) (typecaseq (cadr x) (FIXNUM 'FIXNUM) ((FLONUM FLONUM-S) 'FLONUM) (SMALL-FLONUM '()) (EXTEND (not (memq (typep x) '(BIGNUM BIGFLOAT))) ) (T 'T)) x)) (defun P1-CONS-A-QUOTE (item mode original) (cons-a-NODE FUNFORM CL:quote-funform ARGLIST (list (cons-a-COMP KIND 'QUOTE DATA (cons-a-LOC KIND 'QUOTE DATA item))) ORIGINAL original MODE mode )) (defun P1-ALL-ARGS (ff l) (cons-a-NODE FUNFORM ff ARGLIST (mapcar 'P1 (cdr l)) ORIGINAL l)) (defun specialify-var (x forcedp) (cons-a-VAR SRCNAM x SRCTYPE (cond (forcedp '(FREE T)) ('T '(FREE () ))) SPECIALP 'T HOMELOC (cons-a-LOC KIND 'SPECIAL DATA x) MODE (find-var-mode x))) (defun find-var-mode (x) (and (setq x (or (get x 'NUMVAR) (assq x LOCAL-MODES))) (caddr x))) (defun p1-pickup-typeless-null (f l) CL:typeless-nilnode ) ;; P1-NUMBEROF-ARGS? ### check number of args from argspectrum of funform ; warn if wrong, and fill out shorties with ()'s (defun p1-numberof-args? (ff form) (let ((as (FUNFORM-argspectrum ff)) (nargs (length (cdr form)))) (cond (as (cond ((< (setq nargs (- nargs (ARGSPECTRUM-required as))) 0) (pderr (list form as) |Too few arguments indicated|) (setq form (nconc form (make-list (- nargs))))) ((not (= 0 (ARGSPECTRUM-rest as))) () ) ((> nargs (ARGSPECTRUM-optional as)) (pderr (list form as) |Too many arguments indicated|) (setq form (append form () ) ff (nthcdr (- (length form) nargs 2) form)) (rplacd ff `(PROG1 ,.(cdr ff)))))) ((setq as (assq 'ARGSINFO (FUNFORM-data ff))) (and (not (member nargs (cdr as))) (pushl nargs as)))) form)) ;;; ########## It's not entirely clear what I mean to do here. ;;;Boy, I'll say. --RLB (defun capture-free-variable? (x) (and CAPTURE-FREE-VARIABLE? (bound-in-current-lexical? x) (*throw 'CAPTURE-FREE-VARIABLE? () ))) ;BOUND-IN-CURRENT-LEXICAL? returns the "nearest" VAR structure for the name x ; in the current lexical environment, or () (defun bound-in-current-lexical? (x) (do ((l *LEXICAL-CONTOURS* (cdr l)) (z)) ((null l) ()) (when (do ((l (lamargl-lamvars (car l)) (cdr l))) ((null l) ()) (and (eq x (var-srcnam (setq z (car l)))) (return #T))) (return z)))) ;;; ########## finish this (defun add-var-info (var) () ) ;PHASE2 STUFF: ;COM-MSUBR-1 for the case of minisubr call with args in AR1 AR2 ... ;COM-MSUBR-2R* " " in AR1 AR2 R1 R2 ... ;COM-MSUBR-1R* " " in AR1 R1 R2 ... ;The LOCATE-ARGS creates a "operand" specifier, which may ; include the new LISP-addressing modes ; #(QUOTE ) ; #(SPECIAL ), also LOCAL, FUNCTION, LFUNCTION ; #(@REG AP ) for arguments not moved to argframe extension ; #(@REG FP ) for argframe extension quantities ; #(@REG SP ) from off the top of the stack (defun LCODE-OUT (node) (let ((f (NODE-funform node)) (al (LOCATE-ARGS (COMP-ARGS (NODE-arglist node)))) pat ) (and (null (setq pat (cdr (assq 'VALUE-LCODE (FUNFORM-data f))))) (barf node |Missing VALUE-LCODE - LCODE-OUT?|)) (and (> (length al) 5) (barf node |Too many args - LCODE-OUT|)) (mapc 'output-instruction (arg-copy-subst pat al)))) (defun ARG-COPY-SUBST (form CL:args-list) (DECLARE (SPECIAL CL:args-list CL:destination)) (ARG-COPY-SUBST-1 form)) (defun ARG-COPY-SUBST-1 (form) (DECLARE (SPECIAL CL:args-list CL:destination)) (TYPECASEQ form (SYMBOL (let ((i (posq form '(CL:DESTINATION CL:ARG-MARKER-1 CL:ARG-MARKER-2 CL:ARG-MARKER-3 CL:ARG-MARKER-4 CL:ARG-MARKER-5)))) (cond ((null i) form) ((= i 0) CL:destination) ((nth i CL:args-list))))) (PAIR (cons (ARG-COPY-SUBST-1 (car form)) (ARG-COPY-SUBST-1 (cdr form)))) ((VECTOR VECTOR-S) (MAPF 'VECTOR 'VECTOR 'ARG-COPY-SUBST-1 form)) (T form))) (comment Utilities) (defun MSOUT (w msg flag l1 l2) (let ((OUTFILES CMSGFILES) (TERPRI 'T) (PRINLEVEL l1) (PRINLENGTH l2) (BASE 10.) (*NOPOINT () ) (^R 'T) (^W 'T) (ii 0) ) (and (cond ((or YESWARNTTY (eq flag 'BARF) (null OUTFILES))) ((memq flag '(DATA ERRFL)) (null GAG-ERRBREAKS))) (not (memq TYO OUTFILES)) ;^W shuts off "T" output (push TYO OUTFILES)) (setq ii (+ (cond ((memq flag '(ERRFL DATA BARF)) (princ '|/(COMMENT **ERROR** |) 20.) ('T (princ '|/(COMMENT **** |) 15.)) (flatsize w) 1 (flatc msg))) (prin1 w) (princ '| |) (and (> ii 71.) (princ '|// / |)) (princ msg) (cond ((and TOPFN (not (eq flag 'FASL))) (princ '| in function |) (prin1 TOPFN))) (princ '/)) (cond ((memq flag '(ERRFL DATA)) (cond (QUIT-ON-ERROR (mapc 'FORCE-OUTPUT OUTFILES) (or (eq OUTFILES CMSGFILES) (mapc 'FORCE-OUTPUT CMSGFILES)) ;(quit);Damn it!!! ) ((null GAG-ERRBREAKS) (princ '|/; DATA ERROR - TO PROCEED TYPE $P |) (msout-brk w COBARRAY CREADTABLE 'DATA))) (cond ((eq flag 'ERRFL) (setq errfl 'T)) ('T (error 'DATA)))) ((eq flag 'BARF) (princ '|/;%%%%%%%% COMPILER ERROR - CALL BUG-NIL %%%%%%%% |) (msout-brk w SOBARRAY SREADTABLE 'BARF) (error 'BARF))))) (defun MSOUT-BRK (args OBARRAY READTABLE fl) (mapc 'FORCE-OUTPUT OUTFILES) (or (eq OUTFILES CMSGFILES) (mapc 'FORCE-OUTPUT CMSGFILES)) (let ((MSGFILES '(T)) (BASE 10.) (IBASE 10.) *NOPOINT READ ^R) (*BREAK 'T fl)) (terpri)) (comment code to make DECLARE word) (macro SPECIAL (x) (do-declarations (mapcan '(lambda (x) (cond ((symbolp x) `(,x ,(specialify-var x () ) SPECIAL)) ('t (pderr x |Non-symbol - SPECIAL|) () ))) (cdr x)) compiler-state 'SPECIALVARS)) (macro IGNORE (x) (do-declarations (mapcan '(lambda (x) (cond ((symbolp x) `((,x T IGNORE))) ('t (pderr x |Non-symbol - IGNORE|) () ))) (cdr x)) compiler-state 'IGNOREVARS)) (macro SET-SYMBOLIC-CONSTANT (x) (do-declarations (do ((y (cdr x) (cddr y)) ans) ((null y) (nreverse ans)) (cond ((not (symbolp (car y))) (pderr (car y) |Non-symbol - SET-SYMBOLIC-CONSTANT|)) ('t (push `(,(car y) ,(eval (cadr y)) SYMBOLIC-CONSTANT) ans)))) compiler-state 'SYMBOLICVARS)) (macro FIXNUM (x) (do-declarations (process-number-declarations x 'FIXNUM) compiler-state 'LOCAL-MODES)) (macro FLONUM (x) (do-declarations (process-number-declarations x 'FLONUM) compiler-state 'LOCAL-MODES)) (macro NOTYPE (x) (do-declarations (process-number-declarations x () ) compiler-state 'LOCAL-MODES)) (defun process-number-declarations (l type) (mapcan '(lambda (x) (typcaseq x (SYMBOL `((,x ,type NUMVAR))) (PAIR (let ((typl (mapcar '(lambda (y) (car (memq y '(FIXNUM FLONUM)))) (cdr x)))) `((,x (,(reverse typl) ,type ,.typl) NUMFUN)))) (T (pderr x |Bad item for numeric declarations|) () ))) l)) (defun do-declarations (l state var) (caseq state ((TOPLEVEL MAKLAP DECLARE) (mapc '(lambda (x) (putprop (car x) (cadr x) (caddr x))) l) ;(set var (append l var)) 'T) ((COMPILE) (set var (append L (symeval var)))) (T (error '|Bad args to "do-declarations"| (list var l))))) ;NEW SORTS OF COMPILER-INTERNAL "place-holder" FUNCTIONS ;CL:PROG-SEQ - a prog with a name, but no variables ;CL:CARCDR - next item is a string of A's and D's ;CL:*MAKE-STRING - Since MAKE-STRING wants to expand depending on whether or ; not it had an optional argument . . . ;CL:*MAKE-BITS - Similar argument about BITS (comment SCRWR and expanders) (defun CARCDR-expand (x) (prog (ff l xff arg xx) (setq x (p/.5 x)) (and (or (null (setq ff (get (car x) 'FUNFORM))) (null (setq l (assq 'CARCDR (FUNFORM-data ff)))) (null (cdr x)) ;how would this make it past nargs (cddr x)) ;check in P1-NUMBEROF-ARG? ? (go BAD)) (cond ((or (not (pairp (setq arg (p/.5 (cadr x))))) (not (symbolp (car arg))) (null (setq xff (get (car arg) 'FUNFORM))) (not (eq (FUNFORM-type xff) 'CARCDR))) ;If argument is not itself a CARCDR, and fun is CAR or CDR ... (and (null (cdr l)) (return () ))) ((setq xx (CARCDR-expander arg)) ;Collect the sub-carcdrings and append them to current (and (not (eq (car xx) 'CL:CARCDR)) (go BAD)) (setq l (append l (cadadr xx)) arg (caddr xx))) ('T (and (null (setq xx (assq 'CARCDR (FUNFORM-data xff)))) (go BAD)) (setq l (append l xx) arg (cadr arg)))) (return `(CL:CARCDR ',l ,arg)) BAD (barf x |lost in CARCDR-expand|))) (defun LIST-expander (l) (declare (fixnum ln)) (let ((lln (length (cdr l))) (vll 0) (vlln 0) (l*p (eq (car l) 'LIST*)) (g (gensym)) ) (declare (fixnum lln vll)) (setq vll (* (setq vlln (cond (l*p (1- lln)) ('t lln))) 2)) (cond ((> vlln LIST-FROBBL-LENGTH) (pop l) `((LAMBDA (,g) ,.(do ((i 0 (+ i 2)) z) ((>= i vll) (and l*p (push `(VSET ,g ,(1- i) ,(car l)) z)) (nreverse z)) (push `(VSET ,g ,i ,(car l)) z) (pop l)) (SI:RESTRUCTURE-VECTOR-INTO-LIST ,g)) (MAKE-VECTOR ',vll))) ('T (cond ((null (cdr l)) ''() ) ((and l*p (null (cddr l))) (cadr l)) ((p1iterlist (cdr l) l*p))))))) (defun P1ITERLIST (l fl) (cond ((null (cdr l)) (cond (fl (car l)) ('t `(NCONS ,(car l))))) ('t `(CONS ,(car l) ,(p1iterlist (cdr l) fl))))) (defun CANONICALIZE-name (form) (let ((ff (get (car form) 'FUNFORM))) (and (or (null ff) (null (setq ff (assq 'RENAME (FUNFORM-data ff))))) (barf form |lost data table - CANONICALIZE-name|)) (cons (cadr ff) (cdr form)))) (defun seq-CANONICALIZE-name (form) (let ((ff (get (car form) 'FUNFORM)) (nargs (length (cdr form))) argsp nopts nreq) (declare (fixnum nargs nopts nreq)) (and (or (null ff) (null (setq ff (assq 'RENAME (FUNFORM-data ff)))) (null (setq argsp (FUNFORM-argspectrum ff))) (< (setq nopts (ARGSPECTRUM-optional argsp)) 2) (> nopts 3) (< (setq nreq (ARGSPECTRUM-required argsp)) 1) (> nreq 2)) (barf form |lost data table - seq-CANONICALIZE-name|)) ;### try to figure out if the last optional arg is supplied, and ; then select of of two rename'ings. All optional arguments ; except the last ("cnt") default to 0. ; ff should be "(RENAME )" (cond ((= nargs (+ nreq nopts)) `(,(caddr ff) ,. (cdr form)) ) (`(,(cadr ff) ,@ (cdr form) ,. (nthcdr (- (1+ nargs) (+ nreq nopt)) '(0 0))) )))) (defun MAKE-sequence-expander (form) (let ( ((fun n . w) form)) (caseq fun ((MAKE-STRING MAKE-BITS) (let ((*maker 'CL:*MAKE-STRING) (filler 'STRING-FILL) (zero '(~/))) (cond ((eq fun 'MAKE-BITS) (setq *maker 'CL:*MAKE-BITS filler 'BITS-FILL zero '(0)))) (and (null w) (setq w zero)) (setq form `(,*MAKER ,n)) (cond ((or (null (car w)) (and (pairp (setq w (macro-nil-expand (car w)))) (eq (car w) 'QUOTE) (null (cadr w)))) form) ((setq zero (cond ((not (pairp w)) w) ((eq (car w) 'QUOTE) (cadr w)))) `(,FILLER ,form ,zero)) ('T (let ((seq (gensym)) (val (gensym))) `((LAMBDA (,SEQ ,VAL) (AND ,VAL (,FILLER ,SEQ ,VAL)) ,VAL) ,form ,w)))))) ((MAKE-VECTOR MAKE-LIST) `(,(cond ((eq fun 'make-vector) 'CL:*MAKE-VECTOR) ('CL:*MAKE-LIST)) ,n ,(car w)) ) (MAKE-EXTEND `(CL:*MAKE-EXTEND ,n ,(car w) ,(cadr w) )) (T (error form '|uluz bunkie! - MAKE-sequence-expander|)) ))) (DEFUN CASEQ-expander (X) (PROG (CASEQ-expander-KEYFORM LFORM EXP CASEQ-expander-TYPE-PRED CLAUSES TEM LL TMPVAR) (DECLARE (SPECIAL CASEQ-expander-KEYFORM CASEQ-expander-TYPE-PRED)) (SETQ EXP (CDR X)) (POP EXP CASEQ-expander-KEYFORM) (AND (OR (ATOM EXP) (ATOM (CAR EXP))) (DBARF X |Bad CASEQ format|)) (COND ((NOT (ATOM CASEQ-expander-KEYFORM)) (SETQ TMPVAR (GENSYM)) (SETQ LFORM `((LAMBDA (,tmpvar) () ) ,CASEQ-expander-KEYFORM)) (SETQ CASEQ-expander-KEYFORM TMPVAR))) (SETQ CASEQ-expander-TYPE-PRED (ASSQ (TYPEP (COND ((ATOM (CAAR EXP)) (CAAR EXP)) ('T (CAAAR EXP)))) '((SYMBOL . EQ) (FIXNUM . =) (FLONUM . =$)))) (AND (NULL CASEQ-expander-TYPE-PRED) (RETURN () )) (SETQ LL EXP CLAUSES () ) A (COND (LL (PUSH (CONS (COND ((ATOM (CAR LL)) (RETURN () )) ((ATOM (CAAR LL)) (COND ((EQ (CAAR LL) 'T) ''T) ((CASEQ-expander-CLAUSE (CAAR LL))) ('T (RETURN () )))) ('T (SETQ TEM (MAPCAR 'CASEQ-expander-CLAUSE (CAAR LL))) (AND (MEMQ () TEM) (RETURN () )) (COND ((NULL (CDR TEM)) (CAR TEM)) ((CONS 'OR TEM))) )) (CDAR LL)) CLAUSES) (POP LL) (GO A))) (SETQ EXP (CONS 'COND (NREVERSE CLAUSES))) (RETURN (COND (LFORM (RPLACA (CDDAR LFORM) EXP) LFORM) (EXP))) )) (DEFUN CASEQ-expander-CLAUSE (X) (DECLARE (SPECIAL CASEQ-expander-TYPE-PRED CASEQ-expander-KEYFORM)) (COND ((NOT (EQ (TYPEP X) (CAR CASEQ-expander-TYPE-PRED))) () ) (`(,(cdr CASEQ-expander-TYPE-PRED) ,CASEQ-expander-KEYFORM ',X)))) (include ((NILSRC) LET)) (defun LET-expander (l) (caseq (car l) (LET (LET-expander-1 (cdr l))) (LET* (LET*-expander-1 (cdr l))) (T (error '|Lost in LET-expander?|)))) (defun DESETQ-expander (l) (DESETQ-expander-1 (cdr l))) (defun PUSH-expander (X) (COND ((EQ (CAR X) 'POP) (COND ((OR (NULL (CADR X)) (NOT (SYMBOLP (CADR X))) (AND (CADDR X) (NOT (SYMBOLP (CADDR X))))) (PDERR X |POP requires (non-null) symbols for SETQing|) '(PROG1 '())) ((NULL (CDDR X)) `(PROG1 (CAR ,(cadr x)) (SETQ ,(cadr x) (CDR ,(cadr x))))) (`(PROG2 (SETQ ,(caddr x) (CAR ,(cadr x)) ,(cadr x) (CDR ,(cadr x))) ,(caddr x)))) ) ((OR (NULL (CADDR X)) (NOT (SYMBOLP (CADDR X)))) (PDERR X |PUSH requires 2nd arg to be a (non-null) symbol for SETQing|) ''()) (`(SETQ ,(caddr x) (CONS ,(cadr x) ,(caddr x)))) )) (defun DO-expander (xx) (prog (indxl endtst endval endtst-retval tg1 lvars stepdvars lvals body bdfp tem name) (setq body (cond ((eq (car xx) 'DO-NAMED) (setq name (cadr xx)) (cddr xx)) ('T (cdr xx)))) (cond ((and (car body) (atom (car body))) ;old-style? (let (((v i s e . b) body)) (setq indxl `((,v ,i ,s)) endtst e body b endval (list '()) tg1 (list (gensym))))) ('T (pop body indxl) (cond ((null (pop body endtst))) ((atom endtst) (setq bdfp 'T)) ((setq endval (cond ((atom (cdr endtst)) ()) ((and (null (cddr endtst)) (or (null (setq tem (p/.5 (cadr endtst)))) (and (not (atom tem)) (eq (car tem) 'QUOTE) (not (atom (cdr tem))) (null (cadr tem))))) '() ) ('T (reverse (cdr endtst)))) endtst (car endtst) tg1 (list (gensym))) )))) (and endtst (setq endtst-retval `((COND (,endtst ,.(nreverse (cdr endval)) (RETURN ,(car endval)) ))))) (mapc '(lambda (x) (cond ((atom x) (push x lvars) (push () lvals)) ('T (push (car x) lvars) (push (cond ((and (cdr x) (atom (cdr x))) (setq bdfp 'T) () ) ('T (cond ((cddr x) (push x stepdvars) (and (cdddr x) (setq bdfp 'T)))) (cadr x))) lvals) (setq x (car x)))) (and (not (symbolp x)) (setq bdfp 'T))) indxl) (cond ((or bdfp (and (null tg1) endtst-retval)) (PDERR xx |Bad DO format|) (return CL:typeless-nilnode))) (setq lvars (nreverse lvars) lvals (nreverse lvals)) (and stepdvars ;pushed up in reverse order (do ((l) (s stepdvars (cdr s))) ((null s) (setq stepdvars (list l))) (let (((var () step) (car s))) (setq l (if (null l) `(setq ,var ,step) `(setq ,var (prog1 ,step ,l))))))) (return `((LAMBDA ,lvars ,.(and (not (atom (car body))) (eq (caar body) 'DECLARE) (prog1 (ncons (car body)) (pop body))) (CL:PROG-SEQ ,name ,.tg1 ,.endtst-retval ,@body ,.stepdvars ,(cond (tg1 `(GO ,(car tg1))) ((null endtst-retval) '(RETURN () ))))) ,.lvals)) )) (defun PROG-expander (l) (let (progtype name varlist decl badf desetql vals) (pop l progtype) (pop l name) (typecaseq name (CONSTANT (cond ((null name) () ) ;FOO! "name" and "varlist" ('T (setq badf 'T)))) ; can both be null (SYMBOL (pop l varlist)) (PAIR (setq varlist name name () )) ;wasn't a name, after all (#T (setq badf 'T))) (and (not badf) (atom l) (setq badf 'T)) (cond ((not badf) (and (not (atom (car l))) (eq (caar l) 'DECLARE) (setq decl (list (pop l))))) ('T (setq varlist () ))) (setq varlist (mapcar '(lambda (x) (push CL:unspecified vals) (typecaseq x (SYMBOL x) (PAIR (cond ((or (not (symbolp (car x))) (and (cdr x) (not (pairp (cdr x))))) (setq badf 'T) () ) ('T (push (cadr x) desetql) (car x)))) (#T (setq badf 'T)))) varlist)) (and desetql (not (eq progtype 'PROG-LET)) (setq badf 'T)) (setq desetql (nreverse desetql)) ;vals is homogeneous list (cond (badf (pderr l |PROG varlist or name mixed up|) (setq name () varlist () desetql ()))) `((LAMBDA ,varlist ,.decl (CL:PROG-SEQ ,name ,.desetql ,. l)) ,. vals))) (comment MAP expanders) (defun MAPATOMS-expander (l) (let ((funct (cond ((eq (car l) 'MAPATOMS-ALL) (cadr l)) ((and (pairp (cadr l)) (memq (caadr l) '(QUOTE FUNCTION))) `(,(cadadr l) )) (`(FUNCALL ,(cadadr l))))) (start-pkg (cond ((cddr l) (caddr l)) ('T 'OBARRAY))) (supp (cond ((cdddr l) (cadddr l)) (''T))) (sym (gensym)) (tag (gensym)) (pkgl (gensym)) (pkg (gensym)) ) (cond ((eq (car l) 'MAPATOMS-ALL) `(PROG (,pkgl) (SETQ ,pkgl (LIST ,start-pkg)) ,tag (MAPC '(LAMBDA (,pkg) (MAPATOMS ,(cadr l) ,pkg () ) (SETQ ,pkgl (APPEND (PACKAGE-SUB-PACKAGES ,pkg) ,pkgl))) (PROG1 ,pkgl (SETQ ,pkgl () ))) (AND (NULL ,pkgl) (RETURN () )) (GO ,tag))) ((typecaseq supp (SYMBOL 'T) (PAIRP (or (not (eq (car supp) 'QUOTE)) (not (null (cadr supp))))) (T 'T)) `(PROG (,pkg) (SETQ ,pkg ,start-pkg) ,tag (MAPF PROJ1 VECTOR '(LAMBDA (,sym) (AND ,sym (,.funct ,sym))) (SI:PACKAGE-SYMBOL-TABLE ,pkg)) (AND (NULL (SETQ ,pkg (PACKAGE-SUPER-PACKAGE ,pkg))) (RETURN () )) (GO ,tag))) ('T `(MAPF PROJ1 VECTOR '(LAMBDA (,sym) (AND ,sym (,.funct ,sym))) (SI:PACKAGE-SYMBOL-TABLE ,start-pkg)))))) (include ((NILSRC) MAPFX)) (comment MACROS for FUNFORM setups) (declare (setq DEFMACRO-FOR-COMPILING () DEFMACRO-CHECK-ARGS () DEFMACRO-DISPLACE-CALL () )) ;Macro for generating FUNFORM properties for subrs. ;We don't want the name to start with "DEF" so @ won't lose so bad. ;We'll be doing this sort of stuff for a lot of Lisp's builtin stuff. (defmacro PUTFUNFORM (name &rest pairs) (setq pairs (append '(()) pairs ())) ;so we can do GET,PUTPROP (or (get pairs 'name) (putprop pairs `',name 'name)) (let ((as (get pairs 'argspectrum))) (cond (as (let (((req opt rest) as)) (putprop pairs `(cons-a-argspectrum ,.(and req `(required ,req)) ,.(and opt `(optional ,opt)) ,.(and rest `(rest ,rest))) 'argspectrum))))) `(putprop ',name (cons-a-funform ,.(cdr pairs)) 'funform)) ;Macro for generating Source-Code-ReWrite-Rule code for a (subr type) FUNFORM (defmacro defSCRWRinfo (name &optional (expand-fun (implode (nconc (exploden name) '(/- e x p a n d e r)))) args data) `(PUTPROP ',name ',(cons-a-FUNFORM NAME name TYPE 'subr SCRWR expand-fun ARGSPECTRUM (cond ((null args) () ) ((and (= (car args) 1) (or (null (cadr args)) (and (= (cadr args) 0) (or (null (caddr args)) (= (caddr args) 0))))) 1-REQ-ARG) ('t (cons-a-ARGSPECTRUM REQUIRED (car args) OPTIONAL (or (cadr args) 0) REST (or (caddr args) 0) ))) P1FUN () P2FUN () P2FUN-BR () DATA data ) 'FUNFORM)) ;Source-code rewrites for "special-forms" (defmacro defSCRWRinfoSF (name &optional (expand-fun (implode (nconc (exploden name) '(/- e x p a n d e r))))) `(PUTPROP ',name ',(cons-a-FUNFORM NAME name TYPE 'special-form SCRWR expand-fun P1FUN () P2FUN () P2FUN-BR () ) 'FUNFORM)) ;;; Macro for generating code for a FUNFORM for a minisubr ; COM-MSUBR-1 for the case of minisubr call with 1 arg in AR1 ; COM-MSUBR-2R* " " args in AR1 AR2 R1 R2 ... ; COM-MSUBR-1R* " " args in AR1 R1 R2 ... (defmacro defMS (name &optional (args '(1 0)) (p2fun 'COM-MSUBR-1) data) `(PUTPROP ',name ',(cons-a-FUNFORM TYPE 'MSUBR NAME name P2FUN p2fun ARGSPECTRUM (cond ((null args) () ) ((and (= (car args) 1) (or (null (cadr args)) (= (cadr args) 0))) 1-REQ-ARG) ('t (cons-a-ARGSPECTRUM REQUIRED (car args) OPTIONAL (or (cadr args) 0)))) DATA data ) 'FUNFORM)) (defmacro defseq-RENAME (name args *name /-name) `(defSCRWRinfo ,name seq-CANONICALIZE-name ,args ((RENAME ,*name ,/-name)))) (defmacro defseqMS (name args msnamel) `(defMS ,name ,args COM-MSUBR-2R* ((MSUBR-NAME ,(implode (append '(M S $ ) msnamel)))))) ;;Maybe sometime make this a subr, instead of a macro? --RLB (defmacro seq-setups (&aux (makel '(M A K E -)) (*makel '(* M A K E -)) dtypl rem remq *remq /-remq mat matq *matq /-matq pos posq *posq /-posq src srcq *srcq /-srcq rpl *rpl /-rpl fll *fll /-fll sub *sub /-sub ) `(PROGN 'COMPILE (defMS GET (1) COM-MSUBR-1 ((MSUBR-NAME MS$GET)) ) (defMS LENGTH (1) COM-MSUBR-1 ((MSUBR-NAME MS$LENGTH)) ) (defseqMS ASSQ (2) (A S S Q) ) (defSCRWRinfo MAKE-EXTEND MAKE-sequence-expander (1 2) ) (defseqMS *MAKE-EXTEND (3) (E C O N S)) ,.(mapcan '(lambda (dtyp) (setq dtypl (explodec dtyp)) (setq sub (append dtypl '(- S U B S E Q)) *sub (implode-pkg (cons '* sub) 'CL) /-sub (implode-pkg (cons '/- sub) 'CL) sub (implode sub) fll (append dtypl '(- F I L L)) *fll (implode-pkg (cons '* fll) 'CL) /-fll (implode-pkg (cons '/- fll) 'CL) fll (implode fll) rpl (append dtypl '(- R E P L A C E)) *rpl (implode-pkg (cons '* rpl) 'CL) /-rpl (implode-pkg (cons '/- rpl) 'CL) rpl (implode rpl) pos (implode (append dtypl '(- P O S I T I O N))) posq (append dtypl '(- P O S Q)) *posq (implode-pkg (cons '* posq) 'CL) /-posq (implode-pkg (cons '/- posq) 'CL) posq (implode posq) rem (implode (append dtypl '(- R E M O V E))) remq (append dtypl '(- R E M Q)) *remq (implode-pkg (cons '* remq) 'CL) /-remq (implode-pkg (cons '/- remq) 'CL) remq (implode remq) src (implode (append dtypl '(- S E A R C H))) srcq (append dtypl '(- S E A R C H Q)) *srcq (implode-pkg (cons '* srcq) 'CL) /-srcq (implode-pkg (cons '/- srcq) 'CL) srcq (implode srcq) mat (implode (append dtypl '(- M I S M A T C H))) matq (append dtypl '(- M I S M A T C H Q)) *matq (implode-pkg (cons '* matq) 'CL) /-matq (implode-pkg (cons '/- matq) 'CL) matq (implode matq) ) `( ;info for MAKE-seq, for various kinds of "seq"uences (defSCRWRinfo ,(implode (append makel dtypl)) MAKE-sequence-expander (1 1) ) (defseqMS ,(implode (append *makel dtypl)) (2) ,(cons (car dtypl) '(C O N S)) ) ;info for seq-SUBSEQ, for various kinds of "seq"uences (defseq-RENAME ,sub (1 2) ,*sub ,/-sub) (defseqMS ,*sub (1 1) ,`(,(car dtypl) /. S U B S E Q) ) (defseqMS ,/-sub (1 2) ,`(,(car dtypl) /_ S U B S E Q) ) ;info for seq-FILL, for various kinds of "seq"uences (defseq-RENAME ,fll (2 2) ,*fll ,/-fll) (defseqMS ,*fll (2 1) ,`(,(car dtypl) /. F I L L)) (defseqMS ,/-fll (2 2) ,`(,(car dtypl) /_ F I L L)) ;info for seq-REPLACE, for various kinds of "seq"uences (defseq-RENAME ,rpl (2 3) ,*rpl ,/-rpl) (defseqMS ,*rpl (2 2) ,`(,(car dtypl) /. R E P L A C E)) (defseqMS ,/-rpl (2 3) ,`(,(car dtypl) /_ R E P L A C E) ) ;info for seq-POSQ (defseq-RENAME ,posq (2 2) ,*posq ,/-posq) (defseqMS ,*posq (2 1) ,`(,(car dtypl) /. P O S Q)) (defseqMS ,/-posq (2 2) ,`(,(car dtypl) /_ P O S Q) ) ;info for seq-SEARCHQ (defseq-RENAME ,srcq (2 3) ,*srcq ,/-srcq) (defseqMS ,*srcq (2 2) ,`(,(car dtypl) /. S E A R C H Q)) (defseqMS ,/-srcq (2 3) ,`(,(car dtypl) /_ S E A R C H Q) ) ;info for seq-MISMATCHQ (defseq-RENAME ,matq (2 3) ,*matq ,/-matq) (defseqMS ,*matq (2 2) ,`(,(car dtypl) /. M I S M A T C H Q)) (defseqMS ,/-matq (2 3) ,`(,(car dtypl) /_ M I S M A T C H Q) ) ;info for seq-REMQ (defseq-RENAME ,remq (2 2) ,*remq ,/-remq) (defseqMS ,*remq (2 1) ,`(,(car dtypl) /. R E M Q)) (defseqMS ,/-remq (2 2) ,`(,(car dtypl) /_ R E M Q)) ,.(cond ((memq dtyp '(STRING BITS)) `((defseq-RENAME ,pos (2 2) ,*posq ,/-posq) (defseq-RENAME ,src (2 3) ,*srcq ,/-srcq) (defseq-RENAME ,mat (2 3) ,*matq ,/-matq) (defseq-RENAME ,rem (2 2) ,*remq ,/-remq) ))) ;######### what about LIST-MISMATCH, etc. as SUBR? )) '( LIST VECTOR STRING BITS ) ) ) ) (COMMENT FUNFORM SETUP FUNCTIONS) (defun implode-pkg (str pkgnm) ;;; ########## Of course, this has to change when packages work (and (symbolp str) (setq str (explodec str))) (and (symbolp pkgnm) (setq pkgnm (explodec pkgnm))) (and (or (atom str) (atom pkgnm)) (barf |IMPLODE-PKG ??|)) (implode (append pkgnm '(|:|) str))) (defun carcdr-setup (lnames) (cond ((> (length lnames) 4) () ) ((let ((name (implode (cons 'C (append lnames '(R)))))) (putprop name (cons-a-FUNFORM NAME name TYPE 'CARCDR SCRWR 'CARCDR-expand P1FUN () P2FUN () ARGSPECTRUM 1-req-arg DATA `((CARCDR ,.lnames)) ) 'FUNFORM) (carcdr-setup (cons 'A lnames)) (carcdr-setup (cons 'D lnames)))))) (defun SETUP-ALL-FUNFORMS () ;first, a few global constants needed (setq 1-REQ-ARG (cons-a-ARGSPECTRUM REQUIRED 1)) (setq CL:quote-funform (cons-a-FUNFORM NAME 'QUOTE TYPE 'SPECIAL-FORM P1FUN 'P1-QUOTE P2FUN 'COMP-QUOTE )) (putprop 'QUOTE CL:quote-funform 'FUNFORM) (setq CL:truthnode (P1-CONS-A-QUOTE *:truth 'T *:truth)) (setq CL:nilnode (P1-CONS-A-QUOTE () 'T () )) (setq CL:typeless-nilnode (P1-CONS-A-QUOTE () () () )) (setq CL:unspecified '(CL:create-typeless-null)) (putprop 'CL:create-typeless-null (cons-a-FUNFORM NAME 'CL:create-typeless-null P1FUN 'p1-pickup-typeless-null P2FUN () P2FUN-BR () ) 'FUNFORM) ;CAR/CDR stuff (putprop 'CAR (cons-a-FUNFORM NAME 'CAR TYPE 'CARCDR SCRWR 'CARCDR-expand P1FUN 'P1-ALL-ARGS P2FUN 'LCODE-OUT ARGSPECTRUM 1-req-arg DATA '((VALUE-LCODE (CAR CL:ARG-MARKER-1 CL:DESTINATION) ) (CARCDR A) )) 'FUNFORM) (putprop 'CDR (cons-a-FUNFORM NAME 'CDR TYPE 'CARCDR SCRWR 'CARCDR-expand P1FUN 'P1-ALL-ARGS P2FUN 'LCODE-OUT ARGSPECTRUM 1-req-arg DATA '((VALUE-LCODE (CDR CL:ARG-MARKER-1 CL:DESTINATION) ) (CARCDR D) )) 'FUNFORM) (carcdr-setup '(A A)) (carcdr-setup '(A D)) (carcdr-setup '(D A)) (carcdr-setup '(D D)) (putprop 'CL:CARCDR (cons-a-FUNFORM NAME 'CL:CARCDR TYPE 'CARCDR P1FUN 'P1-ALL-ARGS P2FUN 'P2-CARCDR ARGSPECTRUM (cons-a-ARGSPECTRUM REQUIRED 2)) 'FUNFORM) ;following are for operations on sequences (seq-setups) ;following are for special forms (defSCRWRinfoSF MAPF) (defSCRWRinfoSF MAPATOMS) (defSCRWRinfoSF MAPATOMS-ALL MAPATOMS-expander) (defSCRWRinfoSF LET) (defSCRWRinfoSF LET* LET-expander) (defSCRWRinfoSF DESETQ) (defSCRWRinfoSF DO) (defSCRWRinfoSF DO-NAMED DO-expander) (defSCRWRinfoSF CASEQ) (defSCRWRinfoSF PUSH) (defSCRWRinfoSF POP PUSH-expander) (defSCRWRinfoSF PROG) (defSCRWRinfoSF PROG-LET PROG-expander) ;following for SUBRs (defSCRWRinfo LIST) (defSCRWRinfo LIST* LIST-expander) (defSCRWRinfo NOT CANONICALIZE-name (1) ((RENAME NULL)) ) ) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;;;Atom Word Mode:1 ;; END: &; -*- LISP -*- (and (status nofeature SLINK-DEFINERS) (load '((hmr)slpdef))) (HERALD SLINK) (eval-when (eval compile) (setq slink-file-truename (truename infile))) (DOC-COMMENT "-*-TEXT-*- Please do not modify this file. It is generated by the same file that produces the actual SLINK in the VM and as such must be coordinated with the real thing. If you change this, the real thing will not be changed. You can request slot assignments by placing them on the first page of the file, or by sending me mail. --RWK Assignments to CLINK/SLINK slots Index /| Contents /| Symbolic name ________/|_______________________________/|__________________________________ /| /| ;Large offset range ") (CLINK-START -375) (CLINK -375) (CLINK -374) (CLINK -373) (CLINK -372) (CLINK -371) (CLINK -370) (CLINK -369) (CLINK -368) (CLINK -367) (CLINK -366) (CLINK -365) (CLINK -364) (CLINK -363) (CLINK -362) (CLINK -361) (CLINK -360) (CLINK -359) (CLINK -358) (CLINK -357) (CLINK -356) (CLINK -355) (CLINK -354) (CLINK -353) (CLINK -352) (CLINK -351) (CLINK -350 TAB 32 TYPE_BIT #.(do ((n 0 (1+ n)) (ll () (cons (lsh 1 n) ll))) ((= n 32) (nreverse ll))) "(LSH 1 N), 0<=N<32" "Table of type bits for things like VECTORP") (CLINK -318) (CLINK -317) (CLINK -316) (CLINK -315 MS ALLOC_PGS "Allocate pages for VASLOAD and hacks") (CLINK -314) (CLINK -313) (CLINK -312) (CLINK -311) (CLINK -310) (CLINK -309) (CLINK -308) (CLINK -307) (CLINK -306) (CLINK -305) (CLINK -304) (CLINK -303) (CLINK -302) (CLINK -301 VM TMP_IOBUF "Output buffer for cold-load") (CLINK -300 TM OUTCHAN "Output channel for TYO") (CLINK -299 VM STR_HASH2 "CRC second hash-table addr") (CLINK -298 VM STR_HASH1 "CRC first hash-table addr") (CLINK -297 TM SYM_SPACE "List of vectors of symbols") (CLINK -296 TM SYM_LIST "Symbol Freelist") (CLINK -295 TM INHIB_INT "Interrupt-inhibit flag") (CLINK -294 TM INHIB_GC "GC-inhibit flag") (CLINK -293 QC UNBOUND_V "#!UNBOUND-VALUE!") (CLINK -292 QC UNBOUND_F "#!UNBOUND-FUNCTION!") (CLINK -291 TM STK_DIRTY "Dirty-stack flag") (CLINK -290 QS LAST_SFS "") (CLINK -289 QS FIRST_SFS "") (CLINK -288) (CLINK -287) (CLINK -286) (CLINK -285) (CLINK -284 TAB 252 AFM_MARK #.(do ((n 0 (1+ n)) (ll () (cons (format () "QT$K_AFM_MARKER+<~D@2>" n) ll))) ((= n 252) (nreverse ll))) "CL$QC_AFM+N" "Arg frame markers, 0-252 arguments") (DOC-COMMENT "Start of the 1-byte offset range") (CLINK -32) (CLINK -31 TM POLLP "Interrupt poll flag") (CLINK -30 TM HEAPEDGE "End of heap, where to signal a GC") (CLINK -29 TM HEAP "Start of heap, where to allocate from") (CLINK -28 VM (NULPAGADR PHP$NULPAGE) "Page of NULL's, for initializing, etc.") (CLINK -27 TCU VECTOR "Union of various kinds of VECTOR") (CLINK -26 TCM (SGNBIT #X+80000000) "Mask to clear out or set the sign bit") (CLINK -25 TCM (VECT_ADR #X+80000003) "Mask to abstract the address portion of a vector") (CLINK -24 TCM (LO_TYPEC #X+0FFFFFFE0) "Mask to abstract the low type bits") (CLINK -23 TCM (TYPECODE #X+1FFFFFFC) "Mask to abstract the type code of a pointer") (CLINK -22 TCM (ADDRESS #X+0E0000003) "Mask to abstract the address part of a pointer") (CLINK -21 TC PAIR "Here for luck") (CLINK -20 TCU BITS "Types which BITS operations can work on") (CLINK -19 QC DIRT_MARK "Mark where dirty cruft is pushed on stack") (CLINK -18 QC CCFRAME "#!CCFRAME-MARKER! -- Mark a hardware call frame") (CLINK -17 TCU SEQUENCE "Generalized sequences") (CLINK -16 TCU FIX "Fixnums of various typecodes ...") (CLINK -15 QC TRUTH "#!TRUTH! (also, #T), canonical verity") (CLINK -14 TCU FLONUM "Type mask for any type of flonum") (CLINK -13) (CLINK -12) (CLINK -11) (CLINK -10) (CLINK -9) (CLINK -8 MS SPECBIND "SPECBIND one binding block") (CLINK -7 MS VBIND "SPECBIND Variable one binding block") (CLINK -6 MS UNBIND "Undo one binding block") (CLINK -5 MS IAPPLY "Internal Apply") (CLINK -4 MS IFUNCALL "Internal Funcall") (CLINK -3 MS ISEND "Internal SEND") (CLINK -2 MS INTERRUPT "What to do in response to POLLP set") (CLINK -1 MS THROW "Support for THROW special form") (SLP-OFFSET) (CLINK 0 QC NULL) (CLINK 1) (CLINK 2 MS CAR "Take the CAR, carefully") (CLINK 3 MS CDR "...") (CLINK 4 MS RPLACA "...") (CLINK 5 MS RPLACD "...") (CLINK 6 MS C...R "Generalized CAR/CDR minisubr") (CLINK 7 MS ELT "Generalized sequence selection") (CLINK 8 MS SETELT "Something for (SETF (ELT ...) .) to expand to") (CLINK 9 MS VREF "Vector selection") (CLINK 10 MS VSET "Vector store") (CLINK 11 MS CHAR "Character selection") (CLINK 12 MS RPLACHAR "Character replacement") (CLINK 13 MS BIT "Bit selection") (CLINK 14 MS RPLACBIT "Bit setting") (CLINK 15 MS NPUSH "Nill pusher. Should usually be open compiled") (CLINK 16 MS 0PUSH "0 pusher") (CLINK 17 MS VPUSH "Variable pusher") (CLINK 18 MS CONS "Cons a PAIR") (CLINK 19 MS CONSI "Cons by FLINK Index") (CLINK 20 MS CONSN "NCONS") (CLINK 21 MS LCONS "Cons up a list") (CLINK 22 MS VECT_CONS "Cons up a vector") (CLINK 23 MS STR_CONS "Cons up a string") (CLINK 24 MS BITS_CONS "Cons up a BITS") (CLINK 25 MS EXT_CONS "Cons up an extend") (CLINK 26 MS NTH "LIST ELT") (CLINK 27 MS NTHCDR "UNCDR of LIST ELT") (CLINK 28 MS HNDL_OP "Function entry with &OPTIONALs") (CLINK 29 MS HDNL_OP1 "Function entry with 1 &OPTIONAL") (CLINK 30 MS HNDL_RS "Function entry with 1 &REST") (CLINK 31 MS HNDL_OPRS "Function entry with &OPTIONALs and &REST") (DOC-COMMENT ";End of the 1-byte offset range ;Beginning of large positive offset range ") (CLINK 32 MS BOUNDP) (CLINK 33 MS FBOUNDP) (CLINK 34 MS SYMEVAL) (CLINK 35 MS FSYMEVAL) (CLINK 36 MS APPLYSUBR) (CLINK 37 MS SYMCONS "SI:SYMBOL-CONS") (CLINK 38 MS FXTOFL "*:FIX-TO-FLOAT") (CLINK 39 MS GET) (CLINK 40 MS LENGTH) (CLINK 41 MS LAST) (CLINK 42 MS ASSQ) (CLINK 43 MS MEMQ) (CLINK 44 MS DELQ) (CLINK 45 MS RASSQ) (CLINK 46 MS POSASSQ) (CLINK 47 MS MEMASSQ) (CLINK 48 MS STK_DIRT) (CLINK 49 MS STK_CLEAN) (CLINK 50 MS REST_DIRT) (CLINK 51 MS SFLOAT) (CLINK 52) (CLINK 53) (CLINK 54) (CLINK 55 MS IUDF_ERR "Internal Undefined Function Error") (CLINK 56 MS IMNA_ERR "Internal Macro Not Applicable Error") (CLINK 57 MS WNA_ERR "Internal Wrong No Args Error") (CLINK 58 MS WTA_ERR "Internal Wrong Type Args Error") (CLINK 59 MS PDLDPTH) (CLINK 60 MS SYMTABIDX "SYMBOL-TABLE-INDEX") (CLINK 61 MS STR_HASH "STRING-HASH") (CLINK 62 MS FIND_SLI "SI:FIND-SLINK-INDEX") (CLINK 63 MS FIND_PRVC "SI:FIND_PRIVATE-VALUE-CELL") (CLINK 64 MS L_LENGTH "List Length") (DOC-COMMENT " Sequence operations - the next 28 handle the case when the /"cnt/" argument is directly supplied: ") (CLINK 65 MS L_SUBSEQ) (CLINK 66 MS V_SUBSEQ) (CLINK 67 MS S_SUBSEQ) (CLINK 68 MS B_SUBSEQ) (CLINK 69 MS L_FILL) (CLINK 70 MS V_FILL) (CLINK 71 MS S_FILL) (CLINK 72 MS B_FILL) (CLINK 73 MS L_REPLACE) (CLINK 74 MS V_REPLACE) (CLINK 75 MS S_REPLACE) (CLINK 76 MS B_REPLACE) (CLINK 77 MS L_POSQ) (CLINK 78 MS V_POSQ) (CLINK 79 MS S_POSQ) (CLINK 80 MS B_POSQ) (CLINK 81 MS L_SEARQ) (CLINK 82 MS V_SEARQ) (CLINK 83 MS S_SEARQ) (CLINK 84 MS B_SEARQ) (CLINK 85 MS L_MISMATQ) (CLINK 86 MS V_MISMATQ) (CLINK 87 MS S_MISMATQ) (CLINK 88 MS B_MISMATQ) (CLINK 89 MS L_SKIPQ) (CLINK 90 MS V_SKIPQ) (CLINK 91 MS S_SKIPQ) (CLINK 92 MS B_SKIPQ) (DOC-COMMENT " The next 28 handle the case when the /"cnt/" argument is not supplied, and must be calculated from the lengths of the argument sequences and other numerical arguments: ") (CLINK 93 MS L.SUBSEQ) (CLINK 94 MS V.SUBSEQ) (CLINK 95 MS S.SUBSEQ) (CLINK 96 MS B.SUBSEQ) (CLINK 97 MS L.FILL) (CLINK 98 MS V.FILL) (CLINK 99 MS S.FILL) (CLINK 100 MS B.FILL) (CLINK 101 MS L.REPLACE) (CLINK 102 MS V.REPLACE) (CLINK 103 MS S.REPLACE) (CLINK 104 MS B.REPLACE) (CLINK 105 MS L.POSQ) (CLINK 106 MS V.POSQ) (CLINK 107 MS S.POSQ) (CLINK 108 MS B.POSQ) (CLINK 109 MS L.SEARQ) (CLINK 110 MS V.SEARQ) (CLINK 111 MS S.SEARQ) (CLINK 112 MS B.SEARQ) (CLINK 113 MS L.MISMATQ) (CLINK 114 MS V.MISMATQ) (CLINK 115 MS S.MISMATQ) (CLINK 116 MS B.MISMATQ) (CLINK 117 MS L.SKIPQ) (CLINK 118 MS V.SKIPQ) (CLINK 119 MS S.SKIPQ) (CLINK 120 MS B.SKIPQ) (CLINK 121 MS S.EQUAL) (DOC-COMMENT ";Expansion ") (CLINK 122) (CLINK 123) (CLINK 124) (CLINK 125) (CLINK 126) (CLINK 127) (DOC-COMMENT " SLINK entries Structure of a SLINK entry (examples) value cell: xx /| .+1 /| SL$SVLI_OBARRAY xx /| value /| SL$SVCI_OBARRAY function cell: xx /| .+1 /| SL$SFLI_APPLY xx /| fixnum address of APPLY subr /| SL$SFCI_APPLY ") (SLINK 128 APPLY APPLY () (:FUN SB$UNDEFINED "The standard entry into the interpreter" "filled in when the interpreter" "is loaded, but here so we know where the" "slink index is for the VM.")) (SLINK 130 CATCH CATCH #T (:FUN SB$UNDEFINED "Contains #!UNBOUND-FUNCTION! even though" "it's a special form, for it needs a SLINK " "index for the frame it builds.")) (SLINK 132 SI:RINTERN RINTERN () (:FUN SB$RINTERN "Needed by VASLOAD" "The core INTERN system. Must be in the" "Cold Load so VASLOAD can load the rest of" "the world.")) (SLINK 134 SI:RPKG-FIND-PACKAGE PKG_FIND () (:FUN SB$PKG_FIND "SB$PKG_FIND_PKG Needed by VASLOAD" "The low-level way to find a package from" "its name. Needed in the Cold Load by" "VASLOAD. Analogous to RINTERN in that it" "takes a string and a # of characters to" "use for the name, instead of just a string.")) (SLINK 136 PKG-CREATE-PACKAGE PKG_CREA () (:FUN SB$UNDEFINED "This is called by PKG-FIND-PACKAGE with" "second argument non-null. It is not" "defined in the cold load, but is loaded" "later.")) (SLINK 138 INCH INCH () (:FUN SB$I_INCH "SB$I_INCH, cold load INCH function" "replaced when I/O system is loaded")) (SLINK 140 OUCH OUCH () (:FUN SB$I_OUCH "SB$I_OUCH, cold load OUCH function" "replaced when I/O system is loaded")) (SLINK 142 CERROR CERROR () (:FUN SB$UNDEFINED "Continuable ERROR. Called by" "PKG-FIND-PACKAGE and the error minisubrs")) (SLINK 144 FERROR FERROR () (:FUN SB$UNDEFINED "Fatal ERROR. Called by the error minisubrs")) (SLINK 146 EVAL EVAL () (:FUN SB$UNDEFINED "Obvious! Needed by VASLOAD")) (SLINK 148) (SLINK 150) (SLINK 152) (SLINK 154) (SLINK 156) (SLINK 158) (DOC-COMMENT " ") (SLINK 160) (SLINK 162) (SLINK 164 SI:MINI-SUBR-TABLE MINI_SUB () (:VAL QT$K_MINI_SUB "Vector of info about minisubrs" "See VM documentation [Supply it!]")) (SLINK 166 SI:CONSTANT-NAME-TABLE CONST_TB () (:VAL QT$K_CONST_TB "A vector of dotted pairs of constant and" "it's print-name string.")) (SLINK 168 PACKAGE PACKAGE () (:VAL QT$K_GLBL_PKG "current package (initially USER)")) (SLINK 170 SI:GLOBAL-PACKAGE GLBL_PKG () (:VAL QT$K_GLBL_PKG "The top package in the heirarchy. Needed" "to find the top, and by PKG-FIND-PACKAGE." "Set and used in the VM/cold load.")) (SLINK 172 SI:USER-PACKAGE USER_PKG () (:VAL QT$K_USER_PKG "The /"default/" USER package. Needed for" "PRINT, set in VM.")) (SLINK 174 SI:ERROR-STRINGS ERR_STR () (:VAL QT$K_ERR_STR "Vector of error message strings referenced" "by the VM and maybe by compiled code.")) (SLINK 176) (SLINK 178) (SLINK 180) (SLINK 182) (SLINK 184) (SLINK 186) (SLINK 188) (SLINK 190) (DOC-COMMENT " Internal vector pointers to internal data structures for visibility ") (SLINK 192 SI:SPECPDL SPECPDL () (:VAL 0 "vector-ptr to the SPECPDL (for debuggers)")) (SLINK 194 SI:SPECPDL-ORIGIN SPDLOR () (:VAL 0 "address of beginning of SPECPDL")) (SLINK 196 SI:SPECPDL-TOP SPDLTP () (:VAL 0 "PDL pointer for SPECPDL")) (SLINK 198 SI:SPECPDL-FRONTIER SPDLFR () (:VAL 0 "Point beyond which it's time to start" "finding new space for the SPECPDL")) (SLINK 200 SI:BLINTZ-VECTOR BLINTZ () (:VAL QT$K_BLINTZ "vector-pointer to the BLINTZ (for the sake" "of the interpreter)")) (SLINK 202 SI:SLINK-VECTOR SLINK () (:VAL QT$K_SLINK "vector pointer to the SLINK as a whole")) (SLINK 204 SI:CLINK-SIZE CL_SIZE () (:VAL VM$K_CLINK_SIZE "fixnum # of slots in SLINK-vector devoted" "to CLINK")) (SLINK 206 SI:SLP-OFFSET SLP_OFF () (:VAL VM$K_SLP_OFF "offset from start of SLINK-VECTOR to which" "SLP points")) (SLINK 208 SI:SLINK-SIZE SL_SIZE () (:VAL VM$K_SLINK_SIZE "Current size of the SLINK. This is not the" "same as the size of the SLINK-VECTOR, which" "reflects the total allocation of the SLINK." "This reflects how much of that total is in" "use currently.")) (ENDIT) 0.SAVE .PSECT VM$SYMDEF ABS,NORD,NOWRT .=-375 VM$K_SLINK_SIZE=585 VM$K_BLINTZ_SIZ=82 .BLKL 25 CL$TAB_TYPE_BIT: .BLKL 35 CL$MS_ALLOC_PGS: .BLKL 14 CL$VM_TMP_IOBUF: .BLKL 1 CL$TM_OUTCHAN: .BLKL 1 CL$VM_STR_HASH2: .BLKL 1 CL$VM_STR_HASH1: .BLKL 1 CL$TM_SYM_SPACE: .BLKL 1 CL$TM_SYM_LIST: .BLKL 1 CL$TM_INHIB_INT: .BLKL 1 CL$TM_INHIB_GC: .BLKL 1 CL$QC_UNBOUND_V: .BLKL 1 CL$QC_UNBOUND_F: .BLKL 1 CL$TM_STK_DIRTY: .BLKL 1 CL$QS_LAST_SFS: .BLKL 1 CL$QS_FIRST_SFS: .BLKL 5 CL$TAB_AFM_MARK: .BLKL 253 CL$TM_POLLP: .BLKL 1 CL$TM_HEAPEDGE: .BLKL 1 CL$TM_HEAP: .BLKL 1 CL$VM_NULPAGADR: .BLKL 1 CL$TCU_VECTOR: .BLKL 1 CL$TCM_SGNBIT: .BLKL 1 CL$TCM_VECT_ADR: .BLKL 1 CL$TCM_LO_TYPEC: .BLKL 1 CL$TCM_TYPECODE: .BLKL 1 CL$TCM_ADDRESS: .BLKL 1 CL$TC_PAIR: .BLKL 1 CL$TCU_BITS: .BLKL 1 CL$QC_DIRT_MARK: .BLKL 1 CL$QC_CCFRAME: .BLKL 1 CL$TCU_SEQUENCE: .BLKL 1 CL$TCU_FIX: .BLKL 1 CL$QC_TRUTH: .BLKL 1 CL$TCU_FLONUM: .BLKL 6 CL$MS_SPECBIND: .BLKL 1 CL$MS_VBIND: .BLKL 1 CL$MS_UNBIND: .BLKL 1 CL$MS_IAPPLY: .BLKL 1 CL$MS_IFUNCALL: .BLKL 1 CL$MS_ISEND: .BLKL 1 CL$MS_INTERRUPT: .BLKL 1 CL$MS_THROW: .BLKL 1 CL$QC_NULL: .BLKL 2 CL$MS_CAR: .BLKL 1 CL$MS_CDR: .BLKL 1 CL$MS_RPLACA: .BLKL 1 CL$MS_RPLACD: .BLKL 1 CL$MS_C...R: .BLKL 1 CL$MS_ELT: .BLKL 1 CL$MS_SETELT: .BLKL 1 CL$MS_VREF: .BLKL 1 CL$MS_VSET: .BLKL 1 CL$MS_CHAR: .BLKL 1 CL$MS_RPLACHAR: .BLKL 1 CL$MS_BIT: .BLKL 1 CL$MS_RPLACBIT: .BLKL 1 CL$MS_NPUSH: .BLKL 1 CL$MS_0PUSH: .BLKL 1 CL$MS_VPUSH: .BLKL 1 CL$MS_CONS: .BLKL 1 CL$MS_CONSI: .BLKL 1 CL$MS_CONSN: .BLKL 1 CL$MS_LCONS: .BLKL 1 CL$MS_VECT_CONS: .BLKL 1 CL$MS_STR_CONS: .BLKL 1 CL$MS_BITS_CONS: .BLKL 1 CL$MS_EXT_CONS: .BLKL 1 CL$MS_NTH: .BLKL 1 CL$MS_NTHCDR: .BLKL 1 CL$MS_HNDL_OP: .BLKL 1 CL$MS_HDNL_OP1: .BLKL 1 CL$MS_HNDL_RS: .BLKL 1 CL$MS_HNDL_OPRS: .BLKL 1 CL$MS_BOUNDP: .BLKL 1 CL$MS_FBOUNDP: .BLKL 1 CL$MS_SYMEVAL: .BLKL 1 CL$MS_FSYMEVAL: .BLKL 1 CL$MS_APPLYSUBR: .BLKL 1 CL$MS_SYMCONS: .BLKL 1 CL$MS_FXTOFL: .BLKL 1 CL$MS_GET: .BLKL 1 CL$MS_LENGTH: .BLKL 1 CL$MS_LAST: .BLKL 1 CL$MS_ASSQ: .BLKL 1 CL$MS_MEMQ: .BLKL 1 CL$MS_DELQ: .BLKL 1 CL$MS_RASSQ: .BLKL 1 CL$MS_POSASSQ: .BLKL 1 CL$MS_MEMASSQ: .BLKL 1 CL$MS_STK_DIRT: .BLKL 1 CL$MS_STK_CLEAN: .BLKL 1 CL$MS_REST_DIRT: .BLKL 1 CL$MS_SFLOAT: .BLKL 4 CL$MS_IUDF_ERR: .BLKL 1 CL$MS_IMNA_ERR: .BLKL 1 CL$MS_WNA_ERR: .BLKL 1 CL$MS_WTA_ERR: .BLKL 1 CL$MS_PDLDPTH: .BLKL 1 CL$MS_SYMTABIDX: .BLKL 1 CL$MS_STR_HASH: .BLKL 1 CL$MS_FIND_SLI: .BLKL 1 CL$MS_FIND_PRVC: .BLKL 1 CL$MS_L_LENGTH: .BLKL 1 CL$MS_L_SUBSEQ: .BLKL 1 CL$MS_V_SUBSEQ: .BLKL 1 CL$MS_S_SUBSEQ: .BLKL 1 CL$MS_B_SUBSEQ: .BLKL 1 CL$MS_L_FILL: .BLKL 1 CL$MS_V_FILL: .BLKL 1 CL$MS_S_FILL: .BLKL 1 CL$MS_B_FILL: .BLKL 1 CL$MS_L_REPLACE: .BLKL 1 CL$MS_V_REPLACE: .BLKL 1 CL$MS_S_REPLACE: .BLKL 1 CL$MS_B_REPLACE: .BLKL 1 CL$MS_L_POSQ: .BLKL 1 CL$MS_V_POSQ: .BLKL 1 CL$MS_S_POSQ: .BLKL 1 CL$MS_B_POSQ: .BLKL 1 CL$MS_L_SEARQ: .BLKL 1 CL$MS_V_SEARQ: .BLKL 1 CL$MS_S_SEARQ: .BLKL 1 CL$MS_B_SEARQ: .BLKL 1 CL$MS_L_MISMATQ: .BLKL 1 CL$MS_V_MISMATQ: .BLKL 1 CL$MS_S_MISMATQ: .BLKL 1 CL$MS_B_MISMATQ: .BLKL 1 CL$MS_L_SKIPQ: .BLKL 1 CL$MS_V_SKIPQ: .BLKL 1 CL$MS_S_SKIPQ: .BLKL 1 CL$MS_B_SKIPQ: .BLKL 1 CL$MS_L.SUBSEQ: .BLKL 1 CL$MS_V.SUBSEQ: .BLKL 1 CL$MS_S.SUBSEQ: .BLKL 1 CL$MS_B.SUBSEQ: .BLKL 1 CL$MS_L.FILL: .BLKL 1 CL$MS_V.FILL: .BLKL 1 CL$MS_S.FILL: .BLKL 1 CL$MS_B.FILL: .BLKL 1 CL$MS_L.REPLACE: .BLKL 1 CL$MS_V.REPLACE: .BLKL 1 CL$MS_S.REPLACE: .BLKL 1 CL$MS_B.REPLACE: .BLKL 1 CL$MS_L.POSQ: .BLKL 1 CL$MS_V.POSQ: .BLKL 1 CL$MS_S.POSQ: .BLKL 1 CL$MS_B.POSQ: .BLKL 1 CL$MS_L.SEARQ: .BLKL 1 CL$MS_V.SEARQ: .BLKL 1 CL$MS_S.SEARQ: .BLKL 1 CL$MS_B.SEARQ: .BLKL 1 CL$MS_L.MISMATQ: .BLKL 1 CL$MS_V.MISMATQ: .BLKL 1 CL$MS_S.MISMATQ: .BLKL 1 CL$MS_B.MISMATQ: .BLKL 1 CL$MS_L.SKIPQ: .BLKL 1 CL$MS_V.SKIPQ: .BLKL 1 CL$MS_S.SKIPQ: .BLKL 1 CL$MS_B.SKIPQ: .BLKL 1 CL$MS_S.EQUAL: .BLKL 7 SL$SFL_APPLY: .BLKL 1 SL$SFC_APPLY: .BLKL 1 SL$SFL_CATCH: .BLKL 1 SL$SFC_CATCH: .BLKL 1 SL$SFL_RINTERN: .BLKL 1 SL$SFC_RINTERN: .BLKL 1 SL$SFL_PKG_FIND: .BLKL 1 SL$SFC_PKG_FIND: .BLKL 1 SL$SFL_PKG_CREA: .BLKL 1 SL$SFC_PKG_CREA: .BLKL 1 SL$SFL_INCH: .BLKL 1 SL$SFC_INCH: .BLKL 1 SL$SFL_OUCH: .BLKL 1 SL$SFC_OUCH: .BLKL 1 SL$SFL_CERROR: .BLKL 1 SL$SFC_CERROR: .BLKL 1 SL$SFL_FERROR: .BLKL 1 SL$SFC_FERROR: .BLKL 1 SL$SFL_EVAL: .BLKL 1 SL$SFC_EVAL: .BLKL 17 SL$SVL_MINI_SUB: .BLKL 1 SL$SVC_MINI_SUB: .BLKL 1 SL$SVL_CONST_TB: .BLKL 1 SL$SVC_CONST_TB: .BLKL 1 SL$SVL_PACKAGE: .BLKL 1 SL$SVC_PACKAGE: .BLKL 1 SL$SVL_GLBL_PKG: .BLKL 1 SL$SVC_GLBL_PKG: .BLKL 1 SL$SVL_USER_PKG: .BLKL 1 SL$SVC_USER_PKG: .BLKL 1 SL$SVL_ERR_STR: .BLKL 1 SL$SVC_ERR_STR: .BLKL 17 SL$SVL_SPECPDL: .BLKL 1 SL$SVC_SPECPDL: .BLKL 1 SL$SVL_SPDLOR: .BLKL 1 SL$SVC_SPDLOR: .BLKL 1 SL$SVL_SPDLTP: .BLKL 1 SL$SVC_SPDLTP: .BLKL 1 SL$SVL_SPDLFR: .BLKL 1 SL$SVC_SPDLFR: .BLKL 1 SL$SVL_BLINTZ: .BLKL 1 SL$SVC_BLINTZ: .BLKL 1 SL$SVL_SLINK: .BLKL 1 SL$SVC_SLINK: .BLKL 1 SL$SVL_CL_SIZE: .BLKL 1 SL$SVC_CL_SIZE: .BLKL 1 SL$SVL_SLP_OFF: .BLKL 1 SL$SVC_SLP_OFF: .BLKL 1 SL$SVL_SL_SIZE: .BLKL 1 SL$SVC_SL_SIZE: .RESTORE ;;; The NIL UUO Handler (for compiled NIL code!) ;;; See NILSRC;UUOPAT for description of how the UUO scheme works. ;;; This is USELESS if interpreted. It ***MUST BE COMPILED***. ;;; Maybe clobbers call instruction to be a Maclisp call. ;;; Someday perhaps this will make use of the SUBR/LSUBR-pointer ;;; that's available in the function object... ;;; A note on UUO snapping! The clobbering occurs in the case that ;;; the SUBR's DESCRIPTOR field is the symbol 'SIM:SNAPPABLE. ;;; Snapping must NOT occur in the case of the functions for ;;; any of the "trampolines". (declare (setq defmacro-for-compiling ())) (defmacro DEFCXR (name index) `(DEFMACRO ,name (OB) (LIST 'CXR ',index OB))) (defcxr SI:SUBR-NAME 3) (defcxr SI:SUBR-DESCRIPTOR 4) (defcxr SI:SUBR-DOCUMENTATION 5) (defcxr SIM:SUBR-SYMBOL 0) ;same as NIL-OBJECT-DATUM (defcxr SIM:SUBR-TYPE 6) (defcxr SIM:SUBR-PTR 7) (declare (special sim:uuo-callee sim:uuo-loc sim:uuo-contents) (*lexpr sim:iapply-my-args)) (defmacro bis (&rest x) `(boole 7 ,@x)) (defmacro bic (&rest x) `(boole 2 ,@x)) (defun SIM:UUO-TRAP n (let ((p (si:fsymeval-subr sim:uuo-callee))) (cond ((and (eq (si:subr-descriptor p) 'SIM:SNAPPABLE) (not nouuo)) (deposit (maknum sim:uuo-loc) (bis (maknum (sim:subr-symbol p)) (bic (+ 40_33 777777) sim:uuo-contents))))) (sim:iapply-my-args (sim:subr-symbol p)))))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END: ;-*-MIDAS-*- ;Patching to MacLISP's UUO handler to enable compiled calls to functions ;in the NIL simulator. ;We use UUO opcodes 54-63 to replace MacLISP's CALL thru NJCALF (14-23). ;The handler here sets up some special variables and causes a MacLISP ;function to be run. ;(SIM:UUO-SETUP debug-p) ; sets up to cause this uuo handler to get run. A call to this ; appears as an eval mungeable in this file. ;(SIM:UUO-TRAP &REST callee-args) {not defined in this file} ; gets run instead of the callee. It gets passed the callee's args. ; Of course, it should look at SIM:UUO-CALLEE. ;SIM:UUO-CALLEE {special variable} ; gets SETQ'ed to the callee before SIM:UUO-TRAP is called. ;SIM:UUO-LOC {special variable, random} ; gets SETQ'ed to the location of the uuo itself (i.e., something ; of typep RANDOM). ;SIM:UUO-CONTENTS {special variable, fixnum} ; gets SETQ'ed to the pre-smash contents of the uuo cell, as a fixnum. ; Since it seems undesirable to number cons the contents at low level ; in the UUO handler, we preset at setup time SIM:UUO-CONTENTS to a ; freshly consed fixnum, and (crock!) change the contents of that ; word in fixnum space. .fasl .insrt sys:.fasl defs verprt UUOPAT .entry SIM:UUO-SETUP SUBR 002002 ;Subr of 1 arg push p,a ; skipn a ;nonnull arg says do break at entry skipa t,[jrst nuuoh1] ;nonbreaking handler move t,[jrst nuuob1] ;break first movem t,uuogle"+2 jsp t,fwcons movem a,.special SIM:UUO-CONTENTS skipn (p) jrst setup1 .break 12,setdf1 setup1: movei a,.atom T jrst pop1j" setdef: squoze 0,global ? -,,0 squoze 10,%call ? call+40_33 squoze 10,%jcall ? jcall+40_33 squoze 10,%callf ? callf+40_33 squoze 10,%jcalf ? jcallf+40_33 squoze 10,%ncall ? ncall+40_33 squoze 10,%njcal ? njcall+40_33 squoze 10,%ncalf ? ncallf+40_33 squoze 10,%njclf ? njcalf+40_33 setdfz: -<.-setdef>,,setdef setdf1: ..sstb,,setdfz ;uuogle:0 nuuob1: .value [asciz ":NUUOH1"] nuuoh1: movem t,uutsv" ldb t,[331100,,forty"] ;get the opcode cail t,+40 ;make sure it's in range for a CALL type caile t,+40 jrst uuogl1" ;nope, go let MacLISP barf movem tt,uuttsv" movem r,uursv" movem p,uupsv" move tt,uuogle ;move to MacLISP's uuoh world movem tt,uuoh" move tt,forty ;get the uuo insn itself movem tt,@.special SIM:UUO-CONTENTS ;clobber in fixnum space tlz tt,(40_33) ;turn off our uuo bit tlo tt,(2_33) ;the no-clobber bit, the 'F' in CALLF ;Since we pretend SIM:UUO-TRAP is the callee, ;we don't want call smashed to it! movem tt,40 hrrzs tt ;get the rh of the UUO, i.e., the callee movem tt,.special SIM:UUO-CALLEE hrrz tt,uuogle ;pc after the uuo subi tt,1 ;pc as of the uuo nuuoh2: ldb r,[331100,,(tt)] ;op code at that pc cain r,xct_-33 ;was it an XCT? jrst nuuxct ;yup, go find the uuo move t,(tt) ;just for the hell of it, make sure we came t,forty ;found the right one! .value [asciz ":nuuoh2 didn't find the uuo"] hrrzm tt,.special SIM:UUO-LOC ldb tt,[270400,,forty] ;a little more setup before reentering UUOH caig tt,15 ;R gets 0 for subrs, 1 for L, 2 for F tdza r,r movei r,-15(tt) movei t,.atom SIM:UUO-TRAP ;let MacLISP run this fcn instead jrst uuoh0a" nuuxct: ldb r,[220400,,(tt)] ;get index field of the XCT jumpe r,.+2 ;skip if none hrrz r,@uuoacs"-1(r) ;else get contents of that ac add r,(tt) ;add in address field hll r,(tt) ;and the op code movei tt,(r) tlne r,(@) jrst nuuxct ;retry to make indirection win jrst nuuoh2 ;reenter, see if this is another XCT constants .sxeva (SIM:UUO-SETUP NIL) ;Poor MIDAS fasend H;-*-MIDAS-*- .fasl .insrt sys:.fasl defs verprt VBIND define subr name,nargs .entry name SUBR nargs+1 termin ;(SIM:PDLPTR-BIND ) ;;;Bind a PDL vector of symbols to their current values. The end ;;;of the vector may be marked by a (). ;;;If a nonsymbol is found, the function SIM:BIND-ERROR is applied ;;;to it. ;(SIM:ARRAY-BIND ) ;;;Similarly, but munges an array of symbols. ;(SIM:UNBIND ) ;;;Undoes a bind block, returning its argument. subr SIM:UNBIND,1 ;unbind a block, and return our arg jrst UNBIND" subr SIM:PDLPTR-BIND,2 movn t,(a) ;number of values hrl b,t ;count maintained here movem sp,SPSV ;begin a bind block jumpge t,SPECX ;don't bind <= nothing! jumpe b,SPECX ;Do nothing if pdlptr is () lp2: hrrz a,(b) ;get a symbol jumpe a,lp2x ;() marks the end SKOTT A,SY ;skip if symbol jrst vblose ;lose if not a symbol hlrz ar1,(a) ;get value cell move ar1,@(ar1) ;get value jsr BIND" ;bind them vbnext: aobjn b,lp2 ;next symbol, and count lp2x: pop p,t ;get return addr jrst SPECX ;go terminate bind block and return vblose: push p,b call 1,.function SIM:VBIND-ERROR pop p,b jrst vbnext ;next symbol subr SIM:ARRAY-BIND,2 movn t,(a) ;number of values hrl b,t ;count maintained here movem sp,SPSV ;begin a bind block jumpe b,SPECX ;Do nothing if array ptr is () jumpge t,SPECX ;don't bind <= nothing! lp1: movei tt,(b) ;arrays sure are clever rot tt,-1 tlcn tt,400000 hrrz a,@ttsar(a) tlcn tt,400000 hlrz a,@ttsar(a) jumpe a,lp2x ;() marks the end SKOTT A,SY ;skip if symbol jrst vblos1 ;lose if not a symbol hlrz ar1,(a) ;get value cell move ar1,@(ar1) ;get value jsr BIND" ;bind them vbnxt1: aobjn b,lp1 ;next symbol, and count popj p, vblos1: push p,b call 1,.function SIM:VBIND-ERROR pop p,b jrst vbnxt1 ;next symbol fasend ;-*-Mode:LISP; Package:SI; BASE:10-*- (herald ADDMTH) (include ((NILSRC) ADDMTM)) ;a bunch of macros (defvar si:initial-method-table-size 39. "Must be a prime. The size of a newly created method-table") (defvar si:flavor-fill-factor 90. "Percent full to fill method tables before growing them.") (defvar si:method-table-size-list '(7. 11. 17. 23. 31. 41. 53. 67. 83. 101. 127. 157. 191. 227. 263. 307. 353. 401. 449. 499. 557. 617. 677. 739. 809. 881. 953. 1031. 1109. 1187. 1277. 1367. 1459. 1553. 1607. 1709. 1801. 1907. 2017. 2129. 2243. 2357. 2473. 2591.) "Good sizes for method hash tables. (must be primes)") ;; A method table consists of a vector with slot 0 containing a count ;; of entries, and the remainder being indexed in blocks of four. ;; (VREF tab idx) contains the key ;; (VREF tab idx+1) contains the method function ;; (VREF tab idx+2) contains the method subr ;; (VREF tab idx+3) contains the map. ;; ... Actually, it's an extend, of METHOD-VECTOR-CLASS, so use SI:XREF ;; The number of entries which have been made into the method table ;(defmacro method-table-nentries (mt) `(si:xref ,mt 0)) #-NIL (defmacro si:address-of (foo) `(maknum ,foo)) ;; The first level hash. ;; This returns the first hash, unmodded. The moding is done at access time. ;(defmacro first-hash (sym) `(si:address-of ,sym) ;; This is the second hash function. ;(defmacro second-hash (sym size) ; `(1+ (mod (si:address-of ,sym) (1- ,size)))) ;; VECTOR-INDEX takes a hash index (i.e. a bucket number, needing MOD ;; of the size of the table-1 done on it), and gives the vector index ;; to find the key. ;(defmacro vector-index (hash size) ; `(1+ (mod (* 4 ,hash) ,size))) ;; Access the key given a hash index. ;(defmacro hash-vref (table hash size) ; `(si:xref ,table (vector-index ,hash ,size))) ;; True mod. (defun mod (x y) (setq x (\ x y)) (if (< x 0) (+ x y) x)) ;(defupdate iaccumulate '+) ;(defmacro increment (frob) ; `(iaccumulate 1 ,frob)) ;; Incomplete (defun add-flavor-method (flavor-symbol key fun map) (let ((flavor (do () (()) (cond ((symbolp flavor-symbol) (let ((flav (flavor-structure flavor-symbol))) (if flav (return flav) (setq flavor-symbol (cerror #T () ':wrong-type-argument "~S is not the name of a flavor" flavor-symbol))))) ((flavorp flavor-symbol) (return flavor-symbol)) (#T (setq flavor-symbol (cerror #T () ':wrong-type-argument "Need a flavor, not ~s" flavor-symbol))))))) (let ((method-table (si:flavor-message->method flavor))) (if (null method-table) ;May be new (setf (si:flavor-message->method flavor) (si:make-method-table (car si:method-table-size-list))) ;;Grow if necessary and be sure we have the new one (setf (si:flavor-message->method flavor) (si:maybe-grow-flavor-method-table method-table))) (setq method-table (si:flavor-message->method flavor)) (let ((idx (si:find-method-in-table method-table key))) (if idx (store-bucket method-table idx key fun (fsymeval fun) map) (store-method-in-table method-table key fun map))))))) ;; STORE-METHOD-IN-TABLE takes a table, a key, a function-symbol (which is ;; FSYMEVALd), and a map, and stores them all in the table. This should ;; only be called once it is determined that the key is not already in ;; the table. That means that some effort should be made to ensure that ;; noone sneaks in and installs a method after we decide it needs to be done. ;; WITHOUT-INTERRUPTS is the simplest and worst of the possible solutions. (defun store-method-in-table (table key fun map) (store-method-in-table-1 table key fun (fsymeval fun) map)) (defun store-method-in-table-1 (table key fun funval map) (let* ((size (method-table-size table)) (first-hash (first-hash key)) (bucket (hash-vref table first-hash size))) (declare (fixnum size first-hash)) (if (eq bucket 0) (progn (store-bucket table first-hash key fun funval map) (increment (method-table-nentries table))) (let ((second-hash (second-hash key (// size 4)))) (declare (fixnum second-hash)) (do ((current-hash (+ first-hash second-hash) (+ current-hash second-hash)) (previous-hash first-hash current-hash) (other-hash 0)) (()) (declare (fixnum current-hash previous-hash other-hash)) (setq bucket (hash-vref table current-hash size)) (when (eq bucket 0) (increment (method-table-nentries table)) (store-bucket table current-hash key fun funval map) (return current-hash)) (setq bucket (hash-vref table previous-hash size)) (setq other-hash (+ previous-hash (second-hash bucket size))) (setq bucket (hash-vref table other-hash size)) (when (eq bucket 0) (move-bucket table previous-hash other-hash) (store-bucket table previous-hash key fun funval map) (increment (method-table-nentries table)) (return previous-hash))))))) (defun si:find-method-in-table (table key) (do ((idx (first-hash key) (+ idx second-hash)) (second-hash (second-hash key (// (method-table-size table) 4))) (size (method-table-size table)) (count 0 (1+ count))) ((>= count size) (ferror () "SI:FIND-METHOD-IN-TABLE ran out of table finding ~s in ~s" key table)) (let ((bucket (hash-vref table idx size))) (if (eq bucket 0) (return ())) ;empty slot, return Failure (if (eq bucket key) (return idx))) ;This index works, return it. )) (defun si:make-method-table (size) (setq size (1+ (* size 4))) (let ((table (si:make-extend size method-table-class))) (setf (si:xref table 0) #+Maclisp (cons 0 (1- size)) #+Nil 0) (do idx 1 (1+ idx) (>= idx size) (setf (si:xref table idx) 0)) table)) (defun si:find-larger-size (size) (do ((list si:method-table-size-list (cdr list))) ((null list) (if (< size 8161.) 8161. ;1024th prime, just punt and make big table (ferror () "SI:FIND-LARGER-SIZE can't find a size larger than ~d" size))) (if (< size (car list)) (return (car list))))) ;Found a good one. (defun si:maybe-grow-flavor-method-table (table) (let ((size (// (method-table-size table) 4))) (if (or (>= (* (method-table-nentries table);100.* # to consider full for. 100.) (* si:flavor-fill-factor size)) ;If truly full, must grow it too (>= (method-table-nentries table) (1- size))) (si:grow-flavor-method-table-to-size table (si:find-larger-size size)) table))) ;Not full -- return the table (defun si:grow-flavor-method-table-to-size (otable size) (let ((table (si:make-method-table size))) (do ((idx 1 (+ idx 4)) (end-idx (1+ (method-table-size otable)))) ((>= idx end-idx)) (if (not (eq (si:xref otable idx) '0)) (store-method-in-table-1 table (si:xref otable idx) ;Key (si:xref otable (1+ idx)) ;fun (si:xref otable (+ 2 idx)) ;funval (si:xref otable (+ 3 idx))))) ;map table)) ;Return the new table #+Maclisp (progn 'compile (defclass* method-table method-table-class object-class) (defmethod* (:print-self method-table-class) (obj stream depth slashifyp) (if (and prinlevel (not (< depth prinlevel))) (princ si:prinlevel-excess stream) (princ "#{METHOD-TABLE" stream) (do ((i 1 (+ i 4)) (count 0) (n (1+ (method-table-size obj)))) ((>= i n) (princ "}" stream)) (let ((slot (si:xref obj i))) (unless (eq slot 0) (when (and prinlength (>= count prinlength)) (princ " " stream) (princ si:prinlength-excess stream) (princ "}" stream) (return 'T)) (princ " " stream) (if slashifyp (prin1 slot stream) (princ slot stream)) (setq count (1+ count)) ))))) (defmethod* (describe method-table-class) (object &optional (stream standard-output) (level 0)) (when (null stream) (setq stream t)) ;foo on maclisp (format stream "~&The METHOD-TABLE at address ~6,48o has ~d methods" (maknum object) (method-table-nentries object)) (do ((i 1 (+ i 4)) (n (1+ (method-table-size object)))) ((>= i n)) (let ((slot (si:xref object i))) (unless (eq slot 0) (format stream " The message ~s runs the method function named ~s" (si:xref object i) (si:xref object (1+ i))) (let ((prinlevel 3) (prinlength 5)) (format stream " Method function: ~s Variable map vector: ~s" (si:xref object (+ i 2)) (si:xref object (+ i 3)))))))) );End of #+Maclisp (progn 'compile ...) ;-*-Mode:LISP; Package:SI; BASE:10-*- ADD-METHOD Macros (eval-when (compile eval) (or (get 'DEFSETF 'VERSION) (load '((LISP) DEFSETF)))) (eval-when (compile eval) (or (get 'umlmac 'version) (load '((lisp) umlmac)))) ;need WHEN #+PDP10 (eval-when (compile eval) (defsetf SI:XREF ((() h n) val) () `(SI:XSET ,h ,n ,val))) ;; A method table consists of a vector with slot 0 containing a count ;; of entries, and the remainder being indexed in blocks of four. ;; (VREF tab idx) contains the key ;; (VREF tab idx+1) contains the method function ;; (VREF tab idx+2) contains the method subr ;; (VREF tab idx+3) contains the map. ;; ... Actually, it's an extend, of METHOD-VECTOR-CLASS, so use SI:XREF ;; The number of entries which have been made into the method table #+Maclisp (defmacro method-table-nentries (mt) `(car (si:xref ,mt 0))) #+Nil (defmacro method-table-nentries (mt) `(si:xref ,mt 0)) ;; The actual size of the table #+Maclisp (defmacro method-table-size (mt) `(cdr (si:xref ,mt 0))) #+Nil (defmacro method-table-size (mt) `(1- (si:extend-length ,mt))) #+Maclisp (defmacro (si:address-of defmacro-for-compiling () defmacro-displace-call ()) (foo) `(maknum ,foo)) ;; The first level hash. ;; This returns the first hash, unmodded. The moding is done at access time. (defmacro first-hash (sym) `(si:address-of ,sym)) ;; This is the second hash function. (defmacro second-hash (sym size) `(1+ (mod (si:address-of ,sym) (1- ,size)))) ;; VECTOR-INDEX takes a hash index (i.e. a bucket number, needing MOD ;; of the size of the table-1 done on it), and gives the vector index ;; to find the key. (defmacro vector-index (hash size) `(1+ (mod (* 4 ,hash) ,size))) ;; Access the key given a hash index. (defmacro hash-vref (table hash size) `(si:xref ,table (vector-index ,hash ,size))) (defmacro increment (frob &optional (howmuch 1)) `(setf ,frob (+ ,frob ,howmuch))) ;; Store into a specific bucket (defmacro store-bucket (table idx key fun subr map &aux (vidx (gentemp 'idx))) `(let ((,vidx (vector-index ,idx (method-table-size ,table)))) (setf (si:xref ,table ,vidx) ,key) (setf (si:xref ,table (1+ ,vidx)) ,fun) (setf (si:xref ,table (+ 2 ,vidx)) ,subr) (setf (si:xref ,table (+ 3 ,vidx)) #+Maclisp (cons ,map ,key) #+Nil ,map))) ;; Copy a bucket to a new location ;; (MOVE-BUCKET TABLE SOURCE-INDEX DESTINATION-INDEX) (defmacro move-bucket (table sidx didx &aux (vsidx (gentemp 'sidx)) (vdidx (gentemp 'vidx))) `(let ((,vsidx (vector-index ,sidx (method-table-size ,table))) (,vdidx (vector-index ,didx (method-table-size ,table)))) (setf (si:xref ,table ,vdidx) (si:xref ,table ,vsidx)) (setf (si:xref ,table (1+ ,vdidx)) (si:xref ,table (1+ ,vsidx))) (setf (si:xref ,table (+ 2 ,vdidx)) (si:xref ,table (+ 2 ,vsidx))) (setf (si:xref ,table (+ 3 ,vdidx)) (si:xref ,table (+ 3 ,vsidx))))) #+Maclisp (eval-when (eval compile) (or (get 'flvext 'version) (load '((algbra) flvext)))) #+Nil (eval-when (eval compile) (defsetf SI:EXTEND-CLASS-OF ((() ext) cls) () `(SI:SET-EXTEND-CLASS-OF ,ext ,cls)) (defun package-symbolconc (pkg &rest syms) (if (fboundp 'pkg-find-package) (let ((package (pkg-find-package pkg))) (declare (special package)) (lexpr-funcall #'symbolconc syms)) ;; Don't know about packages, so just try to be smart (lexpr-funcall #'symbolconc pkg '/: syms))) (defmacro define-initial-structure ((name vm-prefix class pkg) &rest vars &aux (idx 0) (lvar (gensym))) `(progn 'compile ;;Accessors pkg:foo-slot ,@(mapcar #'(lambda (spec) (let (( (var () () documentation) spec)) (prog1 `(defmacro ,(package-symbolconc pkg name '- var) (,lvar) ,documentation `(si:xref ,,lvar ,',idx)) (setq idx (1+ idx))))) vars) ;;Size pkg:foo-size (defvar ,(package-symbolconc pkg name '-size) ,(length vars)) ;;Constructor pkg:make-foo ,(let ((g (gentemp 'pairs)) (cname (package-symbolconc pkg 'make- name))) `(defmacro ,cname (&rest ,g) (initial-structure-constructor-macro ,g ',class ',(mapcar #'car vars) ',(mapcar #'caddr vars)))) ;;Pass the rest of the buck to vmdb ,@(when (and (boundp 'database-p) database-p) (vm-define-initial-structure name vm-prefix class pkg vars)))) (defun initial-structure-constructor-macro (pairs class slots inits) (do ((alist (mapcar #'(lambda (slot init) (cons slot init)) slots inits)) (pairs pairs (cddr pairs)) (vars) (vals)) ((null pairs) (let ((g (gentemp 'the-frob))) `((lambda (,g ,@(nreverse vars)) ,@(do ((alist alist (cdr alist)) (i 0 (1+ i)) (l () (if (cdar alist) (cons `(si:xset ,g ,i ,(cdar alist)) l) l))) ((null alist) (nreverse l))) ,g) (si:make-extend ,(length alist) (get ',class 'si:flavor)) ,@(nreverse vals)))) (let ((apair (assq (car pairs) alist))) (if (null apair) (ferror () "unrecognized slot ~s" (car pairs)) (push (gentemp (car pairs)) vars) (push (cadr pairs) vals) (rplacd apair (car vars)))))) (define-initial-structure (FLAVOR CLS SI:FLAVOR SI) (NAME NAME () "The name of this class This is the name printed by print, the name by which the class is usually refered, and is usually the same as the canonical TYPE of the class.") (TYPES TYPES () "A list of type names this class describes. The first type is the canonical TYPE of the class, and is returned by TYPE-OF. Two-argument TYPEP does a MEMQ down this list, except if the last CDR is non-null, it is a symbol to FUNCALL on the two arguments to the TYPEP.") (CALL-METHOD CALL_METH #'FLAVOR-CALL-INTERPRETER "Minisubr to be invoked to handle FUNCALLing this closure") (SEND-METHOD SEND_METH #'FLAVOR-SEND-INTERPRETER "Minisubr to be invoked to handle delivering a message") ;; After here is flavor-specific stuff. (LAST-UPDATE-TIME UPDATTIME () "Update sequence number of last consistancy check of this class. If this does not equal SI:CLASS-UPDATE-TIME, the class should be sent an UPDATE-SELF message, which will determine if anything has changed, and if so, will update itself. Then this slot will be set to the value of SI:CLASS-UPDATE-TIME on entry.") (MESSAGE->METHOD MSG_MTH () "Hash table of messages, methods and map vectors used by default SEND") (DEFAULT-HANDLER DFLT_HNDL () "Something to FUNCALL if the message is not handled") (INSTANCE-SIZE ?? () "??") ;the number of instance variables (INSTANCE-VARIABLE-SPECBINDS ?? () "??") ;A vector whose 2n'th element is ; a ptr to a value-cell for a special ; instance variable and whose 2n+1'th ; element is the index of the special ; variable in the instance ; This is used by the send interpreter to ; do the binding of instance specials. (INSTANCE-FUNCTION-SPECBINDS ?? () "??") ;Analogous to INSTANCE-VARIABLE-SPECBINDS (SELECT-METHOD ?? () "??") ;This gets called as handler function for ; instance. () means method-combination not ; composed yet. (LOCAL-INSTANCE-VARIABLES ?? () "??") ;Names and initializations, ; not including inherited ones. (ALL-INSTANCE-VARIABLES ?? () "??") ;Just names, only valid when flavor-combination ; composed. (ALL-INSTANCE-VARIABLES-INITS ?? () "??") ;The initializations corresponding to each ; variable in the previous slot, specified ; at DEFFLAVOR time. The value of ; (SI:UNBOUND-MARKER) will be used if ; no init value was specified. (METHOD-TABLE ?? () "??") ;Defined below. (DEPENDS-ON ?? () "??") ;List of names of flavors incorporated into ; this flavor. (DEPENDED-ON-BY ?? () "??") ;List of names of flavors which incorporate ; this one. ; The above are only immediate dependencies. (INCLUDES ?? () "??") ;List of names of flavors to include at the end ; rather than as immediate depends-on's. (PACKAGE ?? () "??") ;Package in which the DEFFLAVOR was done. (DEPENDS-ON-ALL ?? () "??") ;An alist whose entries are of the form ; ( . ) ; Here ranges over all ; flavors depended upon to all levels, ; including this flavor itself. ; () means flavor-combination not composed ; yet. This is used by TYPEP of 2 arguments. (WHICH-OPERATIONS ?? () "??");List of messages handled, created when needed. ; this is () if it has not been computed yet. (GETTABLE-INSTANCE-VARIABLES ?? () "??") ;List of them (SETTABLE-INSTANCE-VARIABLES ?? () "??") ;List of them (INITABLE-INSTANCE-VARIABLES ?? () "??") ;option (INIT-KEYWORDS ?? () "??") ;option (PLIST ?? () "??") ;Esoteric things stored here as properties ;Known: :DEFAULT-HANDLER, ; :ORDERED-INSTANCE-VARIABLES, ; :SPECIAL-INSTANCE-VARIABLES, ; :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES, ; :REQUIRED-INSTANCE-VARIABLES, ; :REQUIRED-METHODS, ; :SELECT-METHOD-ORDER, :DEFAULT-INIT-PLIST ; :DOCUMENTATION ;Just names, for determining functioness ; LOCAL-INSTANCE-FUNCTION-VARIABLES ;An alist, each element of the form ; ( . :FUNCTION-) ; LOCAL-INSTANCE-FUNCTIONS-ALIST ; ADDITIONAL-SPECIAL-VARIABLES ; COMPILE-FLAVOR-METHODS ;The convention on these is supposed to be that ;ones in the keyword packages are allowed to be ;used by users. (ALIST ALIST () "An ALIST of other quantities to be associated with a class. System defined tags include :VERSION -- a version number for this class, incremented when making incompatible changes. :DOCUMENTATION -- Description of the purpose and function of this class :SOURCE-FILE -- The file in which the class was defined.") ) ) ;End of eval-when (eval compile) and NIL target o(eval-when (compile) (setq defmacro-for-compiling ())) (include ((FLAVOR) ADDMTM)) ;a bunch of macros (eval-when (compile) (setq defmacro-for-compiling #T)) ;(defun make-flav* (name &restv component-flavor-names) ; (let ((flav (si:make-flavor))) ; (setf (si:extend-class-of flav) ; (or (get 'si:flavor 'si:flavor) ; ;;Kludge for bootstrap ; 'si:flavor)) ; (setf (si:flavor-name flav) name) ; (setf (si:flavor-send-method flav) #'flavor-send-interpreter) ; (setf (si:flavor-message->method flav) ()) ; (setf (si:flavor-default-handler flav) #'flavor-losing-default-handler) ; ;;Inherit methods ; (loop for component ; being vector-elements of (or component-flavor-names #()) ; downto 0 ;earlier methods in the list will override ; do (let ((method-table (si:flavor-message->method ; (get component 'si:flavor)))) ; (when method-table ; (loop for i from 1 ; to (si:extend-length method-table) by 4 ; do (unless (eq 0 (si:xref method-table i)) ; (add-flavor-method ; name ; (si:xref method-table i) ; (si:xref method-table (+ i 1)) ; (si:xref method-table (+ i 3)))))))) ; ;;Inherit types ; 'foo ; ;;Update dependencies ; 'bar ; ;;Inherit instance variables ; 'tee-hee ; (putprop name flav 'si:flavor) ; name)) ; ;(defmacro defmeth* ((flav msg) args &rest body) ; (let ((flav-fn (package-symbolconc 'si msg '-> flav))) ; `(progn 'compile ; (defun ,flav-fn ,args ,@body) ; (add-flavor-method ',flav ',msg ',flav-fn ())))) (declare (special standard-output prinlength si:prinlength-excess prinlevel si:prinlevel-excess)) ;make-flav* will use 'si:flavor instead of its flavor object. ;(make-flav* 'si:flavor) ;so replace it (let ((fl (si:make-flavor name 'si:flavor))) (putprop 'si:flavor fl 'si:flavor) (si:set-extend-class-of fl fl)) ;Define method-table-class before adding any methods ;(make-flav* 'method-table) ;(setq method-table-class (get 'method-table 'si:flavor)) ;Now we're bootstrapped, I suppose. ;(defmeth* (si:flavor :print-self) (self map msg &rest args) ; (format standard-output "#{FLAVOR ~s}" (si:flavor-name self))) #+foo (defmeth* (method-table :print-self) (self map msg &optional (stream standard-output) (depth 0) (slashifyp #T)) (if (and prinlevel (not (< depth prinlevel))) (princ si:prinlevel-excess stream) (princ "#{METHOD-TABLE" stream) (do ((i 1 (+ i 4)) (count 0) (n (si:extend-length self))) ((>= i n) (princ "}" stream)) (let ((slot (si:xref self i))) (unless (eq slot 0) (when (and prinlength (>= count prinlength)) (princ " " stream) (princ si:prinlength-excess stream) (princ "}" stream) (return 'T)) (princ " " stream) (if slashifyp (prin1 slot stream) (princ slot stream)) (setq count (1+ count)) ))))) ;(make-flav* 'foo) ;(defmeth* (foo :bar) (self map msg &rest args) ; (mumble-foo 'bar->foo self map msg args)) ; ;(defmeth* (foo :baz) (self map msg &rest args) ; (mumble-foo 'baz->foo self map msg args)) ; ;(defun mumble-foo (fn self map msg args) ; (format tyo "~&Method function ~s for message ~s -> ~s with map ~s" ; fn msg self map) ; (unless (null args) ; (format tyo " and args ~s" args)) ; #T) (defun #+NIL send #-NIL zsend (the-instance message &rest args) (let* ((flavor (flavor-of the-instance)) (send-interpreter (si:flavor-send-method flavor))) (lexpr-funcall send-interpreter message the-instance args))) (defun flavor-losing-default-handler (message the-instance &rest args) (cerror #T () 'lost-handler "No flavor handler sending ~s to ~s with ~s" message the-instance args)) (defun flavor-send-interpreter (message the-instance &rest args) (let* ((flavor (flavor-of the-instance)) (vindex (flavor-find-method-index message flavor))) (if (null vindex) (lexpr-funcall (si:flavor-default-handler flavor) message the-instance args) (let* ((method-table (si:flavor-message->method flavor)) (index (vector-index vindex (1- (si:extend-length method-table)))) (method-function (si:xref method-table (+ index 2))) (map-vector (si:xref method-table (+ index 3)))) (lexpr-funcall method-function the-instance map-vector message args))))) (defun flavor-call-interpreter (&rest args) (cerror #T () ':compatibility-lossage "No FLAVOR-CALL-INTERPRETER yet, called on ~s" args)) (defun flavor-find-method-index (message flavor) (let ((method-table (si:flavor-message->method flavor))) (if (null method-table) () (si:find-method-in-table method-table message)))) (defun flavor-of (x) (class-of x)) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END:  ;;;; => Initial Input/Output for VAX/NIL (declare (special tyi tyo defaultf standard-input standard-output si:eof-val prinlength prinlevel)) (eval-when (eval compile) (or (fboundp 'dsk-file-object-truename) (macro-definition 'dsk-file-object-truename) (load '((nilsrc) strmdf)))) (defmacro streamp (stream) `(eq (class-of ,stream) ((lambda () (declare (special stream-class)) stream-class)))) (defun streamp (stream) (declare (special stream-class)) (eq (class-of stream) stream-class)) (defun print-stream (x &optional (stream standard-output)) (if (streamp x) (caseq (stream-type x) (:SFA (format stream "#" (stream-sfa-pname x))) (:TTY (format stream "#" (tty-file-object-truename x) (tty-file-object-mode x))) (:DSK (format stream "#" (dsk-file-object-truename x) (dsk-file-object-mode x))) (#T (format stream "#"))) (format stream "(not-a-stream ~s)" x))) (defun open (filename-arg options-arg) (let ((options (if (atom options-arg) (list options-arg) (list-append options-arg ()))) (filename (canonicalize-namelist (mergef filename-arg defaultf)))) (cond ((memq ':TTY options) (setq options (delq ':TTY options)) (let ((f (cons-tty-file-object filename options))) (si:tty-open f) (let ((errmsg (tty-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:TTY ,@options)) errmsg))))) (#T (setq options (delq ':DSK options)) (let ((f (cons-dsk-file-object filename options))) (cond ((memq ':IN options) (setq options (delq ':IN options)) (si:dsk-openi f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:DSK :IN ,@options)) errmsg)))) ((memq ':OUT options) (setq options (delq ':OUT options)) (si:dsk-openo f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:DSK :OUT ,@options)) errmsg)))) (#T (ferror () "Neither :IN//:OUT for this OPEN ~s" `(open ,filename (:DSK ,@options))))))) ))) (defun probef (filename &optional reasonp) (let ((f (cons-dsk-file-object (mergef filename defaultf) '(:IN)))) (si:dsk-openi f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) (prog1 (dsk-file-object-truename f) (si:dsk-close f)) (if reasonp errmsg ()))))) (defun truename (file) (and (streamp file) (eq (stream-type file) ':dsk) (namelist (dsk-file-object-truename file)))) (defun cons-tty-file-object (filename options) (let ((f (si:make-extend (tty-file-object-size) stream-class))) (setf (stream-type f) ':TTY) (setf (stream-self f) f) (setf (stream-bbc f) ()) (setf (tty-file-object-chan f) 0) (setf (tty-file-object-filename f) (let ((((dev . sd) fn type ver) filename)) (if dev (to-string dev) "TT"))) (setf (tty-file-object-mode f) options) (setf (tty-file-object-error-status f) ()) f)) (defun cons-dsk-file-object (filename options) (let ((f (si:make-extend (dsk-file-object-size) stream-class))) (setf (stream-type f) ':DSK) (setf (stream-self f) f) (setf (stream-bbc f) ()) (setf (dsk-file-object-bits f) ;fab$c_bln + rab$c_bln + nam$c_bln + nam$c_maxrss + max_rec_size ; + 4 + 4 (make-bits (* 8 852))) (setf (dsk-file-object-filename f) (namestring filename)) (setf (dsk-file-object-mode f) options) (setf (dsk-file-object-error-status f) ()) f)) (defun close (f) (if (not (streamp f)) (cerror '#T () ':io-lossage "Closing non-stream ~s" f) (let ((type (stream-type f))) (cond ((eq type ':dsk) (si:dsk-close f)) ((eq type ':tty) (si:tty-close f)) ((eq type ':sfa) (si:sfa-close f)) (#T (send f ':close)))))) (defun io-lossage (call text) (ferror ':io-lossage "I//O Lossage -- VMS error text is ~a~%Call was ~s" text call)) (setq terminal-io (open "TT:" '(:tty)) tyi terminal-io standard-input tyi tyo terminal-io standard-output tyo msgfiles standard-output echofiles ()) (defvar *doing-with-tty-off* () "Rebound by the expansion of DO-WITH-TTY-OFF") (defun inch (&optional (stream standard-input)) (declare (special stream-class standard-input)) (if (not (streamp stream)) (ferror ':wrong-type-argument "INCH from non-stream ~s" stream) (caseq (si:xref stream 0) ((:TTY) (if (stream-bbc stream) (prog1 (stream-bbc stream) (setf (stream-bbc stream) ())) (let ((c (si:tty-inch (si:xref stream 1)))) (unless *doing-with-tty-off* (si:echo-char c stream)) c))) ((:DSK) (if (stream-bbc stream) (prog1 (stream-bbc stream) (setf (stream-bbc stream) ())) (let ((ch (si:dsk-inch (si:xref stream 1)))) (if (null ch) (*throw 'si:read-eof si:eof-val) ch)))) ((:SFA) (si:sfa-inch (si:xref stream 1))) (T (send stream ':inch))))) (defun tyi (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let ((stream standard-input) (eofval si:eof-val)) (when arg1-p (if (streamp arg1) (progn (setq stream arg1) (when arg2-p (setq eofval arg2))) (setq eofval arg1) (when arg2-p (setq stream arg2)))) (let ((si:eof-val eofval)) (char-code (inch stream))))) (defun inchpeek (&optional (stream standard-input)) (caseq (stream-type stream) ((:TTY :DSK) (if (stream-bbc stream) (stream-bbc stream) (let ((ch (inch stream))) (setf (stream-bbc stream) ch) ch))) (:SFA (let ((op (si:sfa-stream-has-operations stream '(tyipeek :tyipeek inchpeek :inchpeek)))) (if op (to-character (sfa-call stream op ())) (if (stream-bbc stream) (stream-bbc stream) (let ((ch (inch stream))) (setf (stream-bbc stream) ch) ch))))) (#T (send stream ':inchpeek)))) (defun tyipeek (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let (stream char) (cond (arg2-p (if (streamp arg2) (setq stream arg2 char arg1) (setq stream arg1 char arg2))) (arg1-p (if (streamp arg1) (setq stream arg1) (setq char arg1 stream standard-input))) (#T (setq stream standard-input))) ;@@ Ignoring CHAR (char-code (inchpeek stream)))) (defun listen (&optional (stream standard-input)) (caseq (stream-type stream) ((:TTY :DSK) (if (stream-bbc stream) 1 0)) (:SFA (let ((op (si:sfa-stream-has-operations stream '(listen :listen)))) (if op (sfa-call stream op ()) (if (stream-bbc stream) 1 0)))) (#T (send stream ':listen)))) (defun ouch (ch &optional (stream standard-output)) (if (not (streamp stream)) (ferror ':wrong-type-argument "OUCH to non-stream ~s" stream) (caseq (si:xref stream 0) ((:TTY) (si:tty-ouch ch (stream-self stream))) ((:DSK) (si:dsk-ouch ch (stream-self stream))) ((:SFA) (si:sfa-ouch ch (stream-self stream))) (T (send stream ':ouch ch))))) (defun oustr (string &optional (stream standard-output)) (loop for c being characters of string do (ouch c stream)) string) (defun tyo (ch &optional (stream standard-output)) (ouch (code-char ch) stream)) (defun si:echo-char (ch stream) (let ((code (char-code ch))) (cond ((< code #\space) (caseq code ((#^G #^H #^I #^J) (ouch ch stream)) (#^M (ouch ch stream) (tyo #^J stream)) (#\alt (ouch ~/$ stream)) (T (ouch ~/^ stream) (tyo (logxor #o100 code) stream)))) ((eq code #\rubout) (oustr "^?" stream)) (#T (ouch ch stream))))) (defun sfa-create (handler-function room pname) (let ((x (si:make-extend (+ (stream-sfa-size) room) stream-class))) (setf (stream-type x) ':sfa) (setf (stream-self x) x) (setf (stream-sfa-function x) handler-function) (setf (stream-sfa-pname x) pname) x)) (defun sfap (x) (and (streamp x) (eq (stream-type x) ':sfa))) (defun sfa-call (sfa op &optional data) (if (sfap sfa) (funcall (stream-sfa-function sfa) sfa op data) (ferror ':wrong-type-argument "SFA-CALL gets non-sfa ~s" sfa))) (defun sfa-get (sfa index) (if (sfap sfa) (stream-sfa-slot sfa index) (ferror ':wrong-type-argument "SFA-GET gets non-sfa ~s" sfa))) (defun sfa-set (sfa index data) (if (sfap sfa) (setf (stream-sfa-slot sfa index) data) (ferror ':wrong-type-argument "SFA-SET gets non-sfa ~s" sfa))) (defun si:sfa-inch (sfa) (to-character (sfa-call sfa ':tyi ()))) (defun si:sfa-ouch (ch sfa) (sfa-call sfa ':tyo (char-code (to-character ch)))) (defun si:sfa-close (sfa) (sfa-call sfa ':close ())) (defun read (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let ((stream standard-input) (eofval ())) (when arg1-p (if (streamp arg1) (progn (setq stream arg1) (when arg2-p (setq eofval arg2))) (progn (setq eofval arg1) (when arg2-p (setq stream arg2))))) (*catch 'si:read-eof (let ((standard-input stream) (si:eof-val eofval)) (declare (special si:eof-val)) (zread))))) (defun print (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprint frob))) (defun prin1 (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprin1 frob))) (defun princ (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprinc frob))) (defun terpri (&optional (stream standard-output)) (if (and (sfap stream) (memq ':terpri (sfa-call stream ':which-operations))) (sfa-call stream ':terpri ()) (ouch #.(to-character #\nl) stream))) (defun si:sfa-stream-has-operations (stream ops) (let ((stream-ops (sfa-call stream ':which-operations))) (dolist (op ops) (when (memq op stream-ops) (return op))))) (setq prinlength () prinlevel ()) (defun si:filemode (file) (do () ((streamp file)) (setq file (cerror #T () ':wrong-type-argument "SI:FILEMODE needs a stream ~s" file))) (let ((type (stream-type file))) (caseq type ((:TTY) (cons `(:TTY ,@(tty-file-object-mode file)) `(cursorpos))) ((:DSK) (cons `(:DSK ,@(dsk-file-object-mode file)) ())) ((:SFA) (let ((operations (sfa-call file 'which-operations))) (if (memq ':FILEMODE operations) (sfa-call file ':FILEMODE ()) (cons '(:SFA) operations)))) (T (send file ':FILEMODE))))) (defun rubout (char &optional (stream standard-output)) (let ((ch (char-code (to-character char)))) (cursorpos 'X stream) (if (>= ch #\space) (when (= ch #\rubout) (cursorpos 'X stream)) (unless (= ch #\altmode) (cursorpos 'X stream))) '#T)) (defun cursorpos (&optional (arg1 () arg1-p) (arg2 () arg2-p) (arg3 () arg3-p)) (let (1st 2nd stream) (cond ((not arg1-p) ;no args (setq stream standard-output)) ((not arg2-p) ;single arg (if (streamp arg1) (setq stream arg1) (setq 1st arg1 stream standard-output))) ((not arg3-p) ;two args (if (streamp arg2) (setq 1st arg1 stream arg2) (setq 1st arg1 2nd arg2 stream standard-output))) ('T (setq 1st arg1 2nd arg2 stream arg3))) (if (sfap stream) (and (memq ':cursorpos (sfa-call stream ':which-operations ())) (sfa-call stream ':cursorpos (and 1st (cons 1st (and 2nd (cons 2nd ())))))) (cerror '#T () ':wrong-type-argument "CURSORPOS ~S ~S on non-SFA ~s" arg1 arg2 arg3)))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END:  <;;;; => Initial Input/Output for VAX/NIL (declare (special tyi tyo standard-input standard-output si:eof-val prinlength prinlevel)) (eval-when (eval compile) (or (fboundp 'dsk-file-object-truename) (macro-definition 'dsk-file-object-truename) (load '((nilsrc) strmdf)))) (defmacro streamp (stream) `(eq (class-of ,stream) ((lambda () (declare (special stream-class)) stream-class)))) (defun streamp (stream) (declare (special stream-class)) (eq (class-of stream) stream-class)) (defun print-stream (x &optional (stream standard-output)) (if (streamp x) (caseq (stream-type x) (:SFA (format stream "#" (stream-sfa-pname x))) (:TTY (format stream "#" (tty-file-object-truename x) (tty-file-object-mode x))) (:DSK (format stream "#" (dsk-file-object-truename x) (dsk-file-object-mode x))) (#T (format stream "#"))) (format stream "(not-a-stream ~s)" x))) (defun open (filename-arg options-arg) (let ((options (if (atom options-arg) (list options-arg) (list-append options-arg ()))) (filename (canonicalize-namelist (mergef filename-arg defaultf)))) (cond ((memq ':TTY options) (setq options (delq ':TTY options)) (let ((f (cons-tty-file-object filename options))) (si:tty-open f) (let ((errmsg (tty-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:TTY ,@options)) errmsg))))) (#T (setq options (delq ':DSK options)) (let ((f (cons-dsk-file-object filename options))) (cond ((memq ':IN options) (setq options (delq ':IN options)) (si:dsk-openi f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:DSK :IN ,@options)) errmsg)))) ((memq ':OUT options) (setq options (delq ':OUT options)) (si:dsk-openo f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) f (io-lossage `(open ,filename (:DSK :OUT ,@options)) errmsg)))) (#T (ferror () "Neither :IN//:OUT for this OPEN ~s" `(open ,filename (:DSK ,@options))))))) ))) (defun probef (filename &optional reasonp) (let ((f (cons-dsk-file-object (mergef filename defaultf) '(:IN)))) (si:dsk-openi f) (let ((errmsg (dsk-file-object-error-status f))) (if (null errmsg) (prog1 (dsk-file-object-truename f) (si:dsk-close f)) (if reasonp errmsg ()))))) (defun cons-tty-file-object (filename options) (let ((f (si:make-extend (tty-file-object-size) stream-class))) (setf (stream-type f) ':TTY) (setf (stream-self f) f) (setf (stream-bbc f) ()) (setf (tty-file-object-chan f) 0) (setf (tty-file-object-filename f) (let ((((dev . sd) fn type ver) filename)) (if dev (to-string dev) "TT"))) (setf (tty-file-object-mode f) options) (setf (tty-file-object-error-status f) ()) f)) (defun cons-dsk-file-object (filename options) (let ((f (si:make-extend (dsk-file-object-size) stream-class))) (setf (stream-type f) ':DSK) (setf (stream-self f) f) (setf (stream-bbc f) ()) (setf (dsk-file-object-bits f) ;fab$c_bln + rab$c_bln + nam$c_bln + nam$c_maxrss + max_rec_size ; + 4 + 4 (make-bits (* 8 852))) (setf (dsk-file-object-filename f) (namestring filename)) (setf (dsk-file-object-mode f) options) (setf (dsk-file-object-error-status f) ()) f)) (defun close (f) (if (not (streamp f)) (cerror '#T () ':io-lossage "Closing non-stream ~s" f) (let ((type (stream-type f))) (cond ((eq type ':dsk) (si:dsk-close f)) ((eq type ':tty) (si:tty-close f)) ((eq type ':sfa) (si:sfa-close f)) (#T (send f ':close)))))) (defun io-lossage (call text) (ferror ':io-lossage "I//O Lossage -- VMS error text is ~a~%Call was ~s" text call)) (setq terminal-io (open "TT:" '(:tty)) tyi terminal-io standard-input tyi tyo terminal-io standard-output tyo msgfiles standard-output echofiles ()) (defvar *doing-with-tty-off* () "Rebound by the expansion of DO-WITH-TTY-OFF") (defun inch (&optional (stream standard-input)) (declare (special stream-class standard-input)) (if (not (streamp stream)) (ferror ':wrong-type-argument "INCH from non-stream ~s" stream) (caseq (si:xref stream 0) ((:TTY) (if (stream-bbc stream) (prog1 (stream-bbc stream) (setf (stream-bbc stream) ())) (let ((c (si:tty-inch (si:xref stream 1)))) (unless *doing-with-tty-off* (si:echo-char c stream)) c))) ((:DSK) (if (stream-bbc stream) (prog1 (stream-bbc stream) (setf (stream-bbc stream) ())) (let ((ch (si:dsk-inch (si:xref stream 1)))) (if (null ch) (*throw 'si:read-eof si:eof-val) ch)))) ((:SFA) (si:sfa-inch (si:xref stream 1))) (T (send stream ':inch))))) (defun tyi (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let ((stream standard-input) (eofval si:eof-val)) (when arg1-p (if (streamp arg1) (progn (setq stream arg1) (when arg2-p (setq eofval arg2))) (setq eofval arg1) (when arg2-p (setq stream arg2)))) (let ((si:eof-val eofval)) (char-code (inch stream))))) (defun inchpeek (&optional (stream standard-input)) (caseq (stream-type stream) ((:TTY :DSK) (if (stream-bbc stream) (stream-bbc stream) (let ((ch (inch stream))) (setf (stream-bbc stream) ch) ch))) (:SFA (let ((op (si:sfa-stream-has-operations stream '(tyipeek :tyipeek inchpeek :inchpeek)))) (if op (to-character (sfa-call stream op ())) (if (stream-bbc stream) (stream-bbc stream) (let ((ch (inch stream))) (setf (stream-bbc stream) ch) ch))))) (#T (send stream ':inchpeek)))) (defun tyipeek (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let (stream char) (cond (arg2-p (if (streamp arg2) (setq stream arg2 char arg1) (setq stream arg1 char arg2))) (arg1-p (if (streamp arg1) (setq stream arg1) (setq char arg1 stream standard-input))) (#T (setq stream standard-input))) ;@@ Ignoring CHAR (char-code (inchpeek stream)))) (defun listen (&optional (stream standard-input)) (caseq (stream-type stream) ((:TTY :DSK) (if (stream-bbc stream) 1 0)) (:SFA (let ((op (si:sfa-stream-has-operations stream '(listen :listen)))) (if op (sfa-call stream op ()) (if (stream-bbc stream) 1 0)))) (#T (send stream ':listen)))) (defun ouch (ch &optional (stream standard-output)) (if (not (streamp stream)) (ferror ':wrong-type-argument "OUCH to non-stream ~s" stream) (caseq (si:xref stream 0) ((:TTY) (si:tty-ouch ch (stream-self stream))) ((:DSK) (si:dsk-ouch ch (stream-self stream))) ((:SFA) (si:sfa-ouch ch (stream-self stream))) (T (send stream ':ouch ch))))) (defun oustr (string &optional (stream standard-output)) (loop for c being characters of string do (ouch c stream)) string) (defun tyo (ch &optional (stream standard-output)) (ouch (code-char ch) stream)) (defun si:echo-char (ch stream) (let ((code (char-code ch))) (cond ((< code #\space) (caseq code ((#^G #^H #^I #^J) (ouch ch stream)) (#^M (ouch ch stream) (tyo #^J stream)) (#\alt (ouch ~/$ stream)) (T (ouch ~/^ stream) (tyo (logxor #o100 code) stream)))) ((eq code #\rubout) (oustr "^?" stream)) (#T (ouch ch stream))))) (defun sfa-create (handler-function room pname) (let ((x (si:make-extend (+ (stream-sfa-size) room) stream-class))) (setf (stream-type x) ':sfa) (setf (stream-self x) x) (setf (stream-sfa-function x) handler-function) (setf (stream-sfa-pname x) pname) x)) (defun sfap (x) (and (streamp x) (eq (stream-type x) ':sfa))) (defun sfa-call (sfa op &optional data) (if (sfap sfa) (funcall (stream-sfa-function sfa) sfa op data) (ferror ':wrong-type-argument "SFA-CALL gets non-sfa ~s" sfa))) (defun sfa-get (sfa index) (if (sfap sfa) (stream-sfa-slot sfa index) (ferror ':wrong-type-argument "SFA-GET gets non-sfa ~s" sfa))) (defun sfa-set (sfa index data) (if (sfap sfa) (setf (stream-sfa-slot sfa index) data) (ferror ':wrong-type-argument "SFA-SET gets non-sfa ~s" sfa))) (defun si:sfa-inch (sfa) (to-character (sfa-call sfa ':tyi ()))) (defun si:sfa-ouch (ch sfa) (sfa-call sfa ':tyo (char-code (to-character ch)))) (defun si:sfa-close (sfa) (sfa-call sfa ':close ())) (defun read (&optional (arg1 () arg1-p) (arg2 () arg2-p)) (let ((stream standard-input) (eofval ())) (when arg1-p (if (streamp arg1) (progn (setq stream arg1) (when arg2-p (setq eofval arg2))) (progn (setq eofval arg1) (when arg2-p (setq stream arg2))))) (*catch 'si:read-eof (let ((standard-input stream) (si:eof-val eofval)) (declare (special si:eof-val)) (zread))))) (defun print (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprint frob))) (defun prin1 (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprin1 frob))) (defun princ (frob &optional (stream standard-output)) (let ((standard-output stream)) (zprinc frob))) (defun terpri (&optional (stream standard-output)) (if (and (sfap stream) (memq ':terpri (sfa-call stream ':which-operations))) (sfa-call stream ':terpri ()) (ouch #.(to-character #\nl) stream))) (defun si:sfa-stream-has-operations (stream ops) (let ((stream-ops (sfa-call stream ':which-operations))) (dolist (op ops) (when (memq op stream-ops) (return op))))) (setq prinlength () prinlevel ()) (defun si:filemode (file) (do () ((streamp file)) (setq file (cerror #T () ':wrong-type-argument "SI:FILEMODE needs a stream ~s" file))) (let ((type (stream-type file))) (caseq type ((:TTY) (cons `(:TTY ,@(tty-file-object-mode file)) `(cursorpos))) ((:DSK) (cons `(:DSK ,@(dsk-file-object-mode file)) ())) ((:SFA) (let ((operations (sfa-call file 'which-operations))) (if (memq ':FILEMODE operations) (sfa-call file ':FILEMODE ()) (cons '(:SFA) operations)))) (T (send file ':FILEMODE))))) (defun rubout (char &optional (stream standard-output)) (let ((ch (char-code (to-character char)))) (cursorpos 'X stream) (if (>= ch #\space) (when (= ch #\rubout) (cursorpos 'X stream)) (unless (= ch #\altmode) (cursorpos 'X stream))) '#T)) (defun cursorpos (&optional (arg1 () arg1-p) (arg2 () arg2-p) (arg3 () arg3-p)) (let (1st 2nd stream) (cond ((not arg1-p) ;no args (setq stream standard-output)) ((not arg2-p) ;single arg (if (streamp arg1) (setq stream arg1) (setq 1st arg1 stream standard-output))) ((not arg3-p) ;two args (if (streamp arg2) (setq 1st arg1 stream arg2) (setq 1st arg1 2nd arg2 stream standard-output))) ('T (setq 1st arg1 2nd arg2 stream arg3))) (if (sfap stream) (and (memq ':cursorpos (sfa-call stream ':which-operations ())) (sfa-call stream ':cursorpos (and 1st (cons 1st (and 2nd (cons 2nd ())))))) (cerror '#T () ':wrong-type-argument "CURSORPOS ~S ~S on non-SFA ~s" arg1 arg2 arg3)))) (defun zformat (stream string1 &restv v1) (let ((v (or v1 #())) (string (to-string string1))) (do ((iv 0) (nv (vector-length v)) (ic 0 (1+ ic)) (nc (string-length string))) ((>= ic nc) '#T) (let ((c (char string ic))) (if (not (eq c '~/~)) (ouch c stream) (setq c (char-upcase (char string (setq ic (1+ ic))))) (caseq c (~/S (if (>= iv nv) (ferror () "FORMAT ran out of args") (prin1 (vref v iv) stream) (setq iv (1+ iv)))) (~/A (if (>= iv nv) (ferror () "FORMAT ran out of args") (princ (vref v iv) stream) (setq iv (1+ iv)))) (~/D (if (>= iv nv) (ferror () "FORMAT ran out of args") (let ((base 10.) (*nopoint 'T)) (declare (special base *nopoint)) (princ (vref v iv) stream)) (setq iv (1+ iv)))) (~/Z (if (>= iv nv) (ferror () "FORMAT ran out of args") (zprint-address (vref v iv) stream) (setq iv (1+ iv)))) ((~/& ~/%) (terpri stream)) (~/~ (ouch c stream)) (#T (ferror () "FORMAT found undefined control char ~s" c)))))))) (defun y-or-n-p (stream string &rest args) (lexpr-funcall #'format stream string args) (loop for c = (progn (format stream " (Y or N) ") (inch stream)) do (caseq (char-upcase c) ((~/Y) (return #T)) ((~/N) (return ()))))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END: s;;;; => Arithmetic for NIL interpreter on VAX ;;;NUMBERS ;Yet to be done: ;signp ;*plus *dif *times *quo ;remainder\ ;gcd \\ ; ;fix ;float ;small-float ;random ; ;haipart ;haulong ;;Here's the set of messages sent (protocol?) for generic arithmetic. ;; The listed args are "R", recipient of the message, and optionally "S", ;; an additional sendee. ;:PLUS ;(PLUS R S) ;:DIFFERENCE ;(DIFFERENCE R S) ;:REVERSE-DIFFERENCE ;(DIFFERENCE S R) ;:MINUS ;(MINUS R) ;:TIMES ;(TIMES R S) ;:QUOTIENT ;(QUOTIENT R S) ;:REVERSE-QUOTIENT ;(QUOTIENT S R) ;:EXPT ;(EXPT R S) ;:REVERSE-EXPT ;(EXPT S R) ;:PLUSP ;(PLUSP R) ;:ZEROP ;(ZEROP R) ;:MINUSP ;(MINUSP R) ;:ODDP ;(ODDP R) ;:LESSP ;(LESSP R S) ;:GREATERP ;(GREATERP R S) ;;Make sure all args are fixnums (defun check-arith-fixnum-args (v fn &optional (k 0)) (dotimes (i (vector-length v)) (do () ((fixnump (vref v i))) (vset v i (cerror #T () ':wrong-type-argument "The ~d arg to ~s is ~s, which is not a fixnum." (+ k i) fn (vref v i)))))) ;;Make sure all args are flonums (defun check-arith-flonum-args (v fn &optional (k 0)) (dotimes (i (vector-length v)) (do () ((flonump (vref v i))) (vset v i (cerror #T () ':wrong-type-argument "The ~d arg to ~s is ~s, which is not a flonum." (+ k i) fn (vref v i)))))) ;;Make sure all args are numbers (defmacro ck-arith-number-args (vars vec fn) (caseq (length vars) (0 `(check-arith-number-args 0 0 ,vec ',fn 0)) (1 `(setf ,(car vars) (check-arith-number-args ,(car vars) 0 ,vec ',fn 1))) (2 `(multiple-value ,vars (check-arith-number-args ,@vars ,vec ',fn 2))) (T (ferror () "Too many vars to CK-ARITH-NUMBER-ARGS ~s" vars)))) (defun check-arith-number-args (a b v fn k) (when (> k 0) (do () ((numberp a)) (setq a (cerror #T () ':wrong-type-argument "The first argument to ~s is ~s, which is not a number." a fn)))) (when (> k 1) (do () ((numberp b)) (setq b (cerror #T () ':wrong-type-argument "The second argument to ~s is ~s, which is not a number." b fn)))) (when v (dotimes (i (vector-length v)) (do () ((numberp (vref v i))) (vset v i (cerror #T () ':wrong-type-argument "The ~d arg to ~s is ~s, which is not a number." (+ k i) fn (vref v i)))))) (multiple-value a b)) ;;Make sure 1+rest args are fixnums (defmacro ck-arith-fixnum1 (a v fn) `(setq ,a (check-arith-fixnum-args1 ,a ,b ',fn))) (defun check-arith-fixnum-args1 (a v fn) (do () ((fixnump a)) (setq a (cerror #T () ':wrong-type-argument "The first arg to ~s is ~s, which is not a fixnum." a))) (check-arith-fixnum-args v fn 1) (values a b)) ;;Make sure 2+rest args are fixnums (defmacro ck-arith-fixnum2 (a b v fn) `(multiple-value (,a ,b) (check-arith-fixnum-args2 ,a ,b ,v ',fn))) (defun check-arith-fixnum-args2 (a b v fn) (do () ((fixnump a)) (setq a (cerror #T () ':wrong-type-argument "The first arg to ~s is ~s, which is not a fixnum." a))) (do () ((fixnump b)) (setq b (cerror #T () ':wrong-type-argument "The second arg to ~s is ~s, which is not a fixnum." b))) (check-arith-fixnum-args v fn 2) (values a b)) ;;Make sure 2+rest args are flonums (defmacro ck-arith-flonum2 (a b v fn) `(multiple-value (,a ,b) (check-arith-flonum-args2 ,a ,b ,v ',fn))) (defun check-arith-flonum-args2 (a b v fn) (do () ((flonump a)) (setq a (cerror #T () ':wrong-type-argument "The first arg to ~s is ~s, which is not a flonum." a))) (do () ((flonump b)) (setq b (cerror #T () ':wrong-type-argument "The second arg to ~s is ~s, which is not a flonum." b))) (check-arith-flonum-args v fn 2) (values a b)) ;;;; => Fixnum arithmetic (defun fixnum-identity (x) (check-arg x fixnump "a fixnum") x) (defun + (&restv v) (check-arith-fixnum-args v '+) (let ((lv (vector-length v))) (do ((i 0 (1+ i)) (result 0)) ((>= i lv) result) (setq result (+ result (vref v i)))))) (defun 1+ (x) (check-arg x fixnump "a fixnum") (1+ x)) (defun - (&optional (first 0 firstp) (second 0 secondp) &restv rest) (when firstp (check-arg first fixnump "a fixnum")) (when secondp (check-arg second fixnump "a fixnum")) (when (> (vector-length rest) 0) (check-arith-fixnum-args rest '-)) (cond ((null secondp) (- first)) ((0p (vector-length rest)) (- first second)) (#T (do ((i 0 (1+ i)) (result (- first second)) (n (vector-length rest))) ((>= i n) result) (setq result (- result (vref rest i))))))) (defun 1- (x) (check-arg x fixnump "a fixnum") (1- x)) (defun * (&restv v) (check-arith-fixnum-args v '*) (if (0p (vector-length v)) 1 (loop with result = 1 for e being vector-elements of v do (setq result (* result e)) finally (return result)))) (defun // (&optional (first 1 firstp) &restv v) (when firstp (check-arg first fixnump "a fixnum")) (cond ((null firstp) 1) ((= 0 (vector-length v)) (// 1 first)) (#T (check-arith-fixnum-args v '//) (loop with result = first for e being vector-elements of v do (setq result (// result e)) finally (return result))))) (defun \ (a b) (check-arg a fixnump "a fixnum") (check-arg b fixnump "a fixnum") (\ a b)) (defun ^ (b x) (check-arg b fixnump "a fixnum") (check-arg x fixnump "a fixnum") (do ((n 1 (* n b)) (i 1 (1+ i))) ((> i x) n))) ;;;; => Flonum arithmetic (defun flonum-identity (x) (check-arg x flonump "a flonum") x) (defun +$ (&restv v) (check-arith-flonum-args v '+$) (let ((lv (vector-length v))) (do ((i 0 (1+ i)) (result 0.0)) ((>= i lv) result) (setq result (+$ result (vref v i)))))) (defun 1+$ (x) (check-arg x flonump "a flonum") (1+$ x)) (defun -$ (&optional (first 0.0 firstp) (second 0.0 secondp) &restv rest) (when firstp (check-arg first flonump "a flonum")) (when secondp (check-arg second flonump "a flonum")) (when (> (vector-length rest) 0) (check-arith-flonum-args rest '-$)) (cond ((null secondp) (-$ first)) ((0p (vector-length rest)) (-$ first second)) (#T (do ((i 0 (1+ i)) (result (-$ first second)) (n (vector-length rest))) ((>= i n) result) (setq result (-$ result (vref rest i))))))) (defun 1-$ (x) (check-arg x flonump "a flonum") (1-$ x)) (defun *$ (&restv v) (check-arith-flonum-args v '*$) (if (0p (vector-length v)) 1.0 (loop with result = 1.0 for e being vector-elements of v do (setq result (*$ result e)) finally (return result)))) (defun //$ (&optional (first 1.0 firstp) &restv v) (when firstp (check-arg first flonump "a flonum")) (cond ((null firstp) 1.0) ((= 0 (vector-length v)) (//$ first)) (#T (check-arith-flonum-args v '//$) (loop with result = first for e being vector-elements of v do (setq result (//$ result e)) finally (return result))))) (defun ^$ (b x) (check-arg b flonump "a flonum") (check-arg x fixnump "a fixnum") (if (-p x) (do ((n 1.0 (//$ n b)) (i -1 (1- i))) ((< i x) n)) (do ((n 1.0 (*$ n b)) (i 1 (1+ i))) ((> i x) n)))) ;;;; => Fixnum, flonum comparisons (defun = (a b &restv v) (ck-arith-fixnum2 a b v =) (and (= a b) (loop for e being vector-elements of v always (= a e)) #T)) (defun =$ (a b &restv v) (ck-arith-flonum2 a b v =$) (and (=$ a b) (loop for e being vector-elements of v always (=$ a e)) #T)) (defun > (a b &restv v) (ck-arith-fixnum2 a b v >) (and (> a b) (loop for e being vector-elements of v always (> (prog1 a (setq a e)) e)) #T)) (defun >$ (a b &restv v) (ck-arith-flonum2 a b v >$) (and (>$ a b) (loop for e being vector-elements of v always (>$ (prog1 a (setq a e)) e)) #T)) (defun < (a b &restv v) (ck-arith-fixnum2 a b v <) (and (< a b) (loop for e being vector-elements of v always (< (prog1 a (setq a e)) e)) #T)) (defun <$ (a b &restv v) (ck-arith-flonum2 a b v <$) (and (<$ a b) (loop for e being vector-elements of v always (<$ (prog1 a (setq a e)) e)) #T)) (defun >= (a b &restv v) (ck-arith-fixnum2 a b v >=) (and (>= a b) (loop for e being vector-elements of v always (>= (prog1 a (setq a e)) e)) #T)) (defun >=$ (a b &restv v) (ck-arith-flonum2 a b v >=$) (and (>=$ a b) (loop for e being vector-elements of v always (>=$ (prog1 a (setq a e)) e)) #T)) (defun <= (a b &restv v) (ck-arith-fixnum2 a b v <=) (and (<= a b) (loop for e being vector-elements of v always (<= (prog1 a (setq a e)) e)) #T)) (defun <=$ (a b &restv v) (ck-arith-flonum2 a b v <=$) (and (<=$ a b) (loop for e being vector-elements of v always (<=$ (prog1 a (setq a e)) e)) #T)) ;;;; => Fixnum logical operations (defun logand (&optional (first 0) &restv rest) (ck-arith-fixnum1 first rest logand) (loop with result = first for e being vector-elements of rest do (setq result (logand result e)) finally (return result))) (defun logior (&optional (first 0) &restv rest) (ck-arith-fixnum1 first rest logior) (loop with result = first for e being vector-elements of rest do (setq result (logior result e)) finally (return result))) (defun logxor (&optional (first 0) &restv rest) (ck-arith-fixnum1 first rest logior) (loop with result = first for e being vector-elements of rest do (setq result (logxor result e)) finally (return result))) (defun logandc1 (x y) (check-arg x fixnump "a fixnum") (check-arg y fixnump "a fixnum") (logandc1 x y)) (defun logandc2 (x y) (check-arg x fixnump "a fixnum") (check-arg y fixnump "a fixnum") (logandc1 y x)) ;(boole fn x y ...) if fn is "abcd" then ; y 0 1 2 3 4 5 6 7 ; | 0 1 0 x*y ~x*y y x*~y x x#y x+y ; ---------- ; 0 | a c 8 9 10 11 12 13 14 15 ; x | ~(x+y) ~(x#y) ~x ~x+y ~y x+~y ~x+~y -1 ; 1 | b d (defun boole (key first &rest rest) (ck-fixnum-args2 key first rest boole) (let ((n (vector-length rest))) (caseq key (0 0) (1 (lexpr-funcall #'logand first rest)) (2 (loop with result = first for i from 0 below n do (setq result (logandc1 result (vref rest i))) finally (return result))) (3 (if (0p n) first (vref rest (1- n)))) (4 (loop with result = first for i from 0 below n do (setq result (logandc2 result (vref rest i))) finally (return result))) (5 first) (6 (lexpr-funcall #'logxor first rest)) (7 (lexpr-funcall #'logior first rest)) (8 (loop with result = first for i from 0 below n do (setq result (lognot (logior result (vref rest i)))) finally (return result))) (9 (loop with result = first for i from 0 below n do (setq result (lognot (logxor result (vref rest i)))) finally (return result))) (10 (lognot first)) (11 (loop with result = first for i from 0 below n do (setq result (logior (lognot result) (vref rest i))) finally (return result))) (12 (lognot (if (0p n) first (vref rest (1- n))))) (13 (loop with result = first for i from 0 below n do (setq result (logior result (lognot (vref rest i)))) finally (return result))) (14 (loop with result = first for i from 0 below n do (setq result (logior (lognot result) (lognot (vref rest i)))) finally (return result))) (15 -1) ;identity (T (lexpr-funcall #'boole (cerror #T () ':wrong-type-argument "Must be fixnum in 0<=n<=15 ~s" key)))))) (defun load-byte (num skip take) (check-arg num fixnump "a fixnum") ;;@@@Need more intelligent range checking here (check-arg skip fixnump "a fixnum") (check-arg take fixnump "a fixnum") (load-byte num skip take)) (defun deposit-byte (num skip take use) (check-arg num fixnump "a fixnum") (check-arg skip fixnump "a fixnum") (check-arg take fixnump "a fixnum") (check-arg use fixnump "a fixnum") (deposit-byte num skip take use)) (defun ldb (num ppss) (load-byte num (load-byte ppss 6 6) (load-byte ppss 0 6))) (defun dpb (num ppss use) (deposit-byte num (load-byte ppss 6 6) (load-byte ppss 0 6) use)) ;(defun bit-test (first &restv rest) ; (loop with fixnum result = first ; for fixnum e being vector-elements of (or rest #()) ; never (= 0 (setq result (logand result e))))) (defun bit-test (x y) (not (= 0 (logand x y)))) (defun ash (x y) (check-arg x fixnump "a fixnum") (check-arg y fixnump "a fixnum") (ash x y)) (defun lsh (x y) (check-arg x fixnump "a fixnum") (check-arg x fixnump "a fixnum") (cond ((>= y 30) 0) ((<= y -30) 0) ((= y 0) x) ((> y 0) (ash x y)) ;left shift (#T ;right shift, can't sign extend. (load-byte x (- y) (- 30 (- y)))))) ; aaa bbbbbbbb 00 ; bbbbbbbb aaa 00 (defun rot (x y) (check-arg x fixnump "a fixnum") (check-arg y fixnump "a fixnum") (let ((n (\ y 30))) ;number to rotate left (when (< n 0) (setq n (+ n 30))) (let ((30-n (- 30 n))) (let ((a (load-byte x 30-n n)) (b (load-byte x 0 30-n))) (deposit-byte a n 30-n b))))) ;;;; => Flonum operations (defun ifloat (x) (check-arg x fixnump "a fixnum") (ifloat x)) ;float, the moby hairy one (defun float (x &rest foo) (if (and (fixnump x) (0p (length foo))) (ifloat x) (cerror #T () ':implementation-lossage "Can't FLOAT ~s with ~s" x foo))) ;fsc ;;;; => Generic arithmetic (defmacro numcond (var fix flo num else) (if (symbolp var) `(cond ((fixnump ,var) ,fix) ((flonump ,var) ,flo) ((numberp ,var) ,num) (#T ,else)) (let ((foo (gentemp 'var))) `((lambda (,foo) (numcond ,foo ,fix ,flo ,num ,else)) ,var)))) (defun plus (&restv rest) (ck-arith-number-args () rest 'plus) (let ((result 0)) (dovector (e rest) (setq result (si:plus-2 result e))) result)) (defun add1 (x) (ck-arith-number-args (x) () 'add1) (si:plus-2 1 x)) (defun si:plus-2 (x1 x2) (cond ((fixnump x1) (cond ((fixnump x2) (si:carefully-fixnum-plus x1 x2)) ((flonump x2) (+$ (ifloat x1) x2)) (#T (send x2 ':plus x1)))) ((flonump x1) (cond ((flonump x2) (+$ x1 x2)) ((fixnump x2) (+$ x1 (ifloat x2))) (#T (send x2 ':plus x1)))) (#T (send x1 ':plus x2)))) ;;Redefined correctly when bignum package is loaded (defun si:carefully-fixnum-plus (x1 x2) (+ x1 x2)) (defun difference (&optional (first 0) &restv rest) (ck-arith-number-args (first) rest 'difference) (let ((result first)) (dovector (e rest) (setq result (si:difference-2 result e))) result)) (defun sub1 (x) (ck-arith-number-args (x) () 'sub1) (si:difference-2 x 1)) (defun si:difference-2 (x1 x2) (cond ((fixnump x1) (cond ((fixnump x2) (si:carefully-fixnum-difference x1 x2)) ((flonump x2) (-$ (ifloat x1) x2)) (#T (send x2 ':reverse-difference x1)))) ((flonump x1) (cond ((flonump x2) (-$ x1 x2)) ((fixnump x2) (-$ x1 (ifloat x2))) (#T (send x2 ':reverse-difference x1)))) (#T (send x1 ':difference x2)))) (defun minus (x) (ck-arith-number-args (x) () 'minus) (cond ((fixnump x) (si:carefully-fixnum-difference 0 x)) ((flonump x) (-$ 0.0 x)) (#T (send x ':minus)))) (defun abs (x) (ck-arith-number-args (x) () 'abs) (cond ((fixnump x) (if (< x 0) (si:carefully-fixnum-difference 0 x) x)) ((flonump x) (if (<$ x 0.0) (-$ 0.0 x) x)) (#T (if (minusp x) (send x ':minus) x)))) ;Redefined correctly when bignum package is loaded (defun si:carefully-fixnum-difference (x1 x2) (- x1 x2)) (defun times (&restv rest) (ck-arith-number-args () rest 'times) (let ((result 1)) (dovector (e rest) (setq result (si:times-2 result e))) result)) (defun si:times-2 (x1 x2) (cond ((fixnump x1) (cond ((fixnump x2) (si:carefully-fixnum-times x1 x2)) ((flonump x2) (*$ (ifloat x1) x2)) (#T (send x2 ':times x1)))) ((flonump x1) (cond ((flonump x2) (*$ x1 x2)) ((fixnump x2) (*$ x1 (ifloat x2))) (#T (send x2 ':times x1)))) (#T (send x1 ':times x2)))) (defun si:carefully-fixnum-times (x y) (* x y)) (defun quotient (&optional (first 1 firstp) &restv rest) (when firstp (ck-arith-number-args (first) rest 'quotient)) (cond ((not firstp) 1) ((= 0 (vector-length rest)) (si:quotient-2 1 first)) (#T (let ((result first)) (dovector (e rest) (setq result (si:quotient-2 result e))) result)))) (defun si:quotient-2 (x1 x2) (cond ((fixnump x1) (cond ((fixnump x2) (si:carefully-fixnum-quotient x1 x2)) ((flonump x2) (//$ (ifloat x1) x2)) (#T (send x2 ':reverse-quotient x1)))) ((flonump x1) (cond ((flonump x2) (//$ x1 x2)) ((fixnump x2) (//$ x1 (ifloat x2))) (#T (send x2 ':reverse-quotient x1)))) (#T (send x1 ':quotient x2)))) (defun si:carefully-fixnum-quotient (x y) (cond ((0p y) (si:divide-by-zero-error x y)) ((1p y) x) (#T (// x y)))) (defun expt (x1 x2) (ck-arith-number-args (x1 x2) () 'expt) (cond ((fixnump x1) (cond ((fixnump x2) (si:carefully-fixnum-expt x1 x2)) ((flonump x2) (//$ (ifloat x1) x2)) (#T (send x2 ':reverse-expt x1)))) ((flonump x1) (cond ((flonump x2) (exp (*$ (log x1) x2))) ((fixnump x2) (si:carefully-flonum-to-fixnum-expt x1 x2)) (#T (send x2 ':reverse-expt x1)))) (#T (send x1 ':expt x2)))) (defun si:carefully-fixnum-expt (a b) (^ a b)) (defun si:carefully-flonum-to-fixnum-expt (x y) (^$ x y)) ;;;; => Generic comparisons (defun plusp (x) (ck-arith-number-args (x) () 'plusp) (cond ((fixnump x) (> x 0)) ((flonump x) (>$ x 0.0)) (#T (send x ':plusp)))) (defun zerop (x) (ck-arith-number-args (x) () 'zerop) (cond ((fixnump x) (= x 0)) ((flonump x) (=$n x 0.0)) (#T (send x ':zerop)))) (defun minusp (x) (ck-arith-number-args (x) () 'minusp) (cond ((fixnump x) (< x 0)) ((flonump x) (<$ x 0.0)) (#T (send x ':minusp)))) (defun oddp (x) (ck-arith-number-args (x) () 'oddp) (cond ((fixnump x) (not (= 0 (logand x 1)))) (#T (send x ':oddp)))) (defun greaterp (a b &restv v) (ck-arith-number-args (a b) v 'greaterp) (and (si:greaterp-2 a b) (loop for e being vector-elements of (or v #()) always (si:greaterp-2 (prog1 a (setq a e)) e)) #T)) (defun lessp (a b &restv v) (ck-arith-number-args (a b) v 'lessp) (and (si:lessp-2 a b) (loop for e being vector-elements of (or v #()) always (si:lessp-2 (prog1 a (setq a e)) e)) #T)) (defun si:greaterp-2 (a b) (cond ((fixnump a) (cond ((fixnump b) (> a b)) ((flonump b) (>$ (ifloat a) b)) (#T (send b ':lessp a)))) ((flonump a) (cond ((fixnump b) (>$ a (ifloat b))) ((flonump b) (>$ a b)) (#T (send b ':lessp a)))) (#T (send a ':greaterp b)))) (defun si:lessp-2 (a b) (cond ((fixnump a) (cond ((fixnump b) (< a b)) ((flonump b) (<$ (ifloat a) b)) (#T (send b ':greaterp a)))) ((flonump a) (cond ((fixnump b) (<$ a (ifloat b))) ((flonump b) (<$ a b)) (#T (send b ':greaterp a)))) (#T (send a ':lessp b)))) (defun max (a &restv v) (ck-arith-number-args (a) v 'max) (loop for e being vector-elements of v do (and (si:greaterp-2 e a) (setq a e)) finally (return a))) (defun min (a &restv v) (ck-arith-number-args (a) v 'min) (loop for e being vector-elements of v do (and (si:lessp-2 e a) (setq a e)) finally (return a))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END:  ;;; BIGNUM -*- Package:System-Internals; Mode:LISP -*- ;;; ************************************************************** ;;; ******************** BIGNUM ARITHMETIC ********************** ;;; ************************************************************** ;;; ** (C) Copyright 1980 Massachusetts Institute of Technology ** ;;; ****** This is a READ-ONLY file! (All writes reserved) ******* ;;; ************************************************************** ;;; ;;; JIMP 10JAN80 ;;; ;;; abstract primitives for implementing bignum arithmetic entirely ;;; in existing NIL, with a roadmap as to where ( and how ) the package ;;; needs tweaking to take advantage of winning instruction sets ;;; available in any specific virtual environment. ;;; (herald bignum) (defvar announce-radix-flag t) (defvar *:bignum-bits-per-word 17) (defvar *:max-bignum-digit (- (^ 2 (1- *:bignum-bits-per-word)) 1)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; BASIC PRIMITIVES ;;; ;;; ;;; ;;; The following primitives are provided written in nil for the sake;;; ;;;of abstractness, however, should be coded in the assembly of which ;;; ;;;ever site the system is implemented on for efficiency if at all ;;; ;;;possible. If nothing else these illustrate how the EXTEND type can ;;; ;;;be employed to increase the power of computation with no real bother ;;; ;;;about system specifics. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun B-PLUS-1 (word1 word2 placev i carry) (declare (fixnum (b-plus-1) word1 word2 i carry)) ; ;places the modular sum of word1, word2, and carry in the ;vector placev location i. returns the new carry. ; (let* ((t1 (+ word1 word2 carry)) (t11 (boole 1 t1 *:max-bignum-digit))) (declare (fixnum t1 t11)) (vset placev i t11) (if (= t1 t11) 0 1))) (defun B-DIFFERENCE-1 (numa numb placev i carry) (declare (fixnum (b-difference-1) numa numb i carry)) ; ;as above only difference ; (let* ((t2 (- numa numb carry)) (t21 (boole 1 t2 *:max-bignum-digit))) (declare (fixnum t2 t21)) (vset placev i t21) (if (= t2 t21) 0 1))) (defun DBL-MULT (wordd1 wordd2 destv i cry5) (declare (fixnum (dbl-mult) wordd1 wordd2 i cry5)) ; ;takes two fixnums wordd1 and wordd2, and computes a double ;word product which is added low word into element i of the ;destination vector destv and high word plus carry cry5 into ;element i+1 of destv. returns the high addition's carry. ; (let* ((kludge (* wordd1 wordd2)) (d0 (boole 1 kludge *:max-bignum-digit)) (d1 (// kludge (^ 2 (1- *:bignum-bits-per-word)))) (cry6 0)) (declare (fixnum kludge d0 d1 cry6)) (setq cry6 (b-plus-1 (vref destv i) d0 destv i 0)) (b-plus-1 (vref destv (1+ i)) d1 destv (1+ i)(+ cry5 cry6)))) (defun B-DIV-1-1 (bjword1 bjword2 bjword3) (declare (fixnum (b-div-1-1) bjword1 bjword2 bjword3)) ; ;divides two fixnums interpreted as a double integer by a third ;fixnum, returns a single fixnum quotient...only single is ;needed from where this is called! ; (// (+ bjword2 (* bjword1 (^ 2 (1- *:bignum-bits-per-word)))) bjword3)) (defun FIND-D (arg) (declare (fixnum (find-d) arg)) ; ;finds a multiplier such that when multiplied by arg, the product ;has the high order bit set. ; (if (> (^ 2 (- *:bignum-bits-per-word 2)) arg) (// (^ 2 (1- *:bignum-bits-per-word))(1+ arg)) 1)) (defun find-high-d (word) (declare (fixnum (find-high-d) word)) ; ;used to find the highest bit set by exponentiation routines ; (do ((i (1- *:bignum-bits-per-word) (1- i)) (old-word word word) (flag-out ())) ((or flag-out (= i 0)) i) (setq word (boole 1 word (1- (^ 2 (1- i))))) (if (= word old-word) t (setq flag-out t)))) (defun B-MULT-1 (sclr vect lnv akum idxrt) (declare (fixnum sclr lnv idxrt)) ; ;scalar multiplies a vector of length lnv returning an ;updated akumulator from element idxrt onward. ;assumes that akum is at least of length lnv+i(+1) ; (let* ((cry4 0) (gadsz akum)) (declare (fixnum cry4)) (do ((j4 0 (1+ j4))) ((= j4 lnv) (cond((= 0 cry4) gadsz) (t (b-plus-1 (vref gadsz (1+ j4)) 0 gadsz (1+ j4) cry4) gadsz))) (let* ((k4 (+ idxrt j4))) (setq cry4 (dbl-mult sclr (vref vect j4) gadsz k4 cry4)))))) (defmacro MAKE-BIGNUM (i) `(let* ((j ,i)(temp (*:make-extend j si:positive-bignum-class))) (do ((k 0 (1+ k)))((= j k) temp) (vset temp k 0)))) (defun ZAP-ZEROS (vnum l) (declare (fixnum l)) ; ;given a bignum-vector of length at least l, truncates that ;vector, eliminating the leading zeros. caveat: rather ;permanent in nature, not for casual use. ; (let ((vnump vnum) (lp l)) (cond ((= lp 1)(set-vector-length vnump 1) vnump) ((= 0 (vref vnump (1- lp))) (zap-zeros vnump (1- lp))) (t (set-vector-length vnump lp) vnump)))) (defun B-TEST (p q b-digit idx1) (declare (fixnum b-digit idx1)) ; ;utility predicate used in b-quotient-2 ; (let* ((tmp2 (make-bignum 4)) (tmp (make-bignum 3)) (tmp1 (make-bignum 3)) (lq (vector-length q))) (dbl-mult b-digit (vref q (- lq 2)) tmp 0 0) (vset tmp1 2 (vref p idx1)) (vset tmp1 1 (vref p (1- idx1))) (vset tmp1 0 (vref p (- idx1 2))) (dbl-mult (vref q (1- lq)) b-digit tmp2 1 0) (b-abs-greaterp (zap-zeros tmp 3) (b-difference-2 (zap-zeros tmp1 3)(zap-zeros tmp2 4))))) (defun B-PLUSP (numa) (eq (*:class-of numa) si:positive-bignum-class)) (defun B-SET-SIGN (num i) (declare (fixnum i)) (*:set-class-of num (if (plusp i) si:positive-bignum-class si:negative-bignum-class))) (defun B-NEGATE (num) (if (eq (*:class-of num) si:positive-bignum-class) (*:set-class-of num si:negative-bignum-class) (*:set-class-of num si:positive-bignum-class))) (defun B-EQUAL (numa numb) (if (not (= (vector-length numa)(vector-length numb))) nil (b-equal-1 numa numb (vector-length numa)))) (defun B-EQUAL-1 (num1 num2 lnth) (declare (fixnum lnth)) ;!!!!!change this to use MISMATCH when its up in the simulator!!! ;utility for above (let ((lnth1 (1- lnth))) (cond ((not (= (vref num1 lnth1)(vref num2 lnth1))) nil) ((zerop lnth1) t) (t (b-equal-1 num1 num2 lnth1))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; MORE PRIMITIVES ;;; ;;; ;;; ;;; The following are a little higher level primitive that might ;;; ;;; reasonably stay in a form that was compiled from nil source; ;;; ;;; however, if the site's instruction set is very powerful, ;;; ;;; these might also be expressed in assembly to take advantage of ;;; ;;; that power. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun B-PLUS-2 (numa numb) ; ;takes numa and numb as positive magnitudes already ( expressed ;also already as bignum vectors ) and returns the magnitude of ;their sum. ; (let* ((la (vector-length numa)) (lb (vector-length numb)) (frobnum (1- (^ 2 (- *:bignum-bits-per-word 2)))) (tmp1 (vref numa (1- la))) (tmp2 (vref numb (1- lb))) (pt (max la lb)) (lc (if (= la lb) (if (or (not (= tmp1 (boole 1 tmp1 frobnum))) (not (= tmp2 (boole 1 tmp2 frobnum)))) (1+ pt) pt) (if (= la pt) (if (= tmp1 (boole 1 tmp1 frobnum)) pt (1+ pt)) (if (= tmp2 (boole 1 tmp2 frobnum)) pt (1+ pt))))) (temp (make-bignum lc)) (carry 0)) (declare (fixnum carry lc pt tmp1 tmp2 frobnum lb la)) (do ((i 0 (1+ i))) ((= i (min la lb)) (if (= la pt) (done-fill numa temp i carry pt lc) (done-fill numb temp i carry pt lc))) (setq carry (b-plus-1 (vref numa i)(vref numb i) temp i carry)) ))) (defun DONE-FILL (num1 temp j cry1 pt lc) (declare (fixnum j cry1 pt lc)) ; ;a utility called by b-plus-2 ; (let ((cry2 cry1)) (declare (fixnum cry2)) (do ((i j (1+ i))) ((or (= pt i)(= cry2 0)) (do ((i i (1+ i))) ((= pt i) (cond ((= 0 cry2)(set-vector-length temp pt) temp) (t (vset temp (1- lc) 1) temp))) (vset temp i (vref num1 i)))) (setq cry2 (b-plus-1 (vref num1 i) 0 temp i cry2))))) (defun B-DIFFERENCE-2 (numa numb) ; ;returns the difference of the magnitudes of numa and numb ;similarly to the action of b-plus-2. caveat: entering here ;assumes that not only both are positive, but that numa >= numb! ; (let* ((av numa) (bv numb) (la (vector-length av)) (lb (vector-length bv)) (temp (make-bignum la)) (cry3 0)) (declare (fixnum la lb cry3)) (do ((i 0 (1+ i))) ((= i lb) (zap-zeros (do ((i i (1+ i))) ((or (= la i)(= cry3 0)) (do ((i i (1+ i))) ((= la i) temp) (vset temp i (vref av i)))) (setq cry3 (b-difference-1 (vref av i) 0 temp i cry3))) la)) (setq cry3 (b-difference-1 (vref av i)(vref bv i) temp i cry3))))) (defun B-TIMES-2 (b-num-a b-num-b) ; ;similar in action to b-plus-2 only with product. ; (let* ((la (vector-length b-num-a)) (lb (vector-length b-num-b)) (lz (+ la lb 1)) (accum (make-bignum lz)) (t4 0)) (declare (fixnum la lb lz t4)) (do ((m 0 (1+ m))) ((= m la) (zap-zeros accum lz)) (setq t4 (vref b-num-a m)) (setq accum (b-mult-1 t4 b-num-b lb accum m))))) (defun B-QUOTIENT-2 (numa numb) ; ;already assumes that numa >= numb in magnitudes ;also assumes that both are strictly bignums! ;again, similar in effect to b-plus-2. ; (let* ((p numa) (q numb) (lp (vector-length p)) (lq (vector-length q)) (lact (- lp lq)) (lquot (+ 2 lact)) (quot (make-bignum lquot)) (frobnum (1- (^ 2 (- *:bignum-bits-per-word 2)))) (b-digit 0) (q-high-digit 0)) (declare (fixnum lp lq lact lquot frobnum b-digit q-high-digit)) ;this is the normalization process.... (setq lp (1+ lp)) (cond ((> frobnum (vref q (1- lq))) (let ((d (find-d (vref q (1- lq))))) (setq q (b-mult-1 d q lq (make-bignum (1+ lq)) 0)) (setq p (b-mult-1 d p (1- lp)(make-bignum lp) 0)))) (t (let ((temp (make-bignum lp))) (do ((ind 0 (1+ ind)))((= (1- lp) ind)) (vset temp ind (vref p ind))) (setq p temp)))) ;begin the loop where the quotient digits are spit out (setq q-high-digit (vref q (1- lq))) (do ((jind lact (1- jind))) ((< jind 0)(zap-zeros quot lquot)) ;calculate a digit for this iteration.... (let* ((idx1 (+ jind lq))) (declare (fixnum idx1)) (setq b-digit (if (= (vref p idx1) q-high-digit) (+ frobnum frobnum 1) (b-div-1-1 (vref p idx1)(vref p (1- idx1)) q-high-digit))) (cond ((b-test p q b-digit idx1) (setq b-digit (1- b-digit)) (if (b-test p q b-digit idx1)(setq b-digit (1- b-digit)) t)) (t t)) ;now update the long-division boxes (let* ((src (vector-replace (make-bignum (1+ lq)) p 0 jind (1+ lq))) (src1 (make-bignum (1+ lq)))) ;should probably find some better way to get this scratch ;space ... this grabs cells every time through! waste, waste ... ;use a separate scratch-pad space for it ! (setq src1 (b-mult-1 b-digit q lq src1 0)) (if (b-abs-greaterp (zap-zeros src1 (1+ lq)) (zap-zeros src (1+ lq))) ;add back code here... (prog ( ) (break 'add-back) (setq b-digit (1- b-digit)) (setq src1 (zap-zeros (b-mult-1 b-digit q lq (make-bignum (1+ lq))0) (1+ lq)))) t) (setq src (b-difference-2 src src1)) (do ((m1 jind (1+ m1))(m2 0 (1+ m2))) ((or (= m2 (vector-length src))(= m2 lq)) (do ((m1 m1 (1+ m1))(m2 m2 (1+ m2)))((= m2 lq)) (vset p m1 0))) (vset p m1 (vref src m2))) )) ;and place the digit in a result space.... (vset quot jind b-digit)))) (defun B-ABS-GREATERP (numa numb) ; ;predicate for numa > numb in magnitude ; (let ((la (vector-length numa))(lb (vector-length numb))) (declare (fixnum la lb)) (cond ((> la lb) t) ((< la lb) nil) (t (b-abs-greaterp-1 numa numb la))))) (defun B-GREATERP (numa numb) (let ((s1 (b-plusp numa)) (s2 (b-plusp numb))) (cond ((and s1 s2)(b-abs-greaterp numa numb)) ((and (not s1)(not s2))(b-abs-greaterp numb numa)) (t (if s1 t nil))))) (defun B-ABS-GREATERP-1 (numa numb la) (declare (fixnum la)) ; ;utility for above code ; (cond ((= la 1)(if (> (vref numa 0)(vref numb 0)) t nil)) ((> (vref numa (1- la))(vref numb (1- la))) t) ((< (vref numa (1- la))(vref numb (1- la))) nil) (t (b-abs-greaterp-1 numa numb (1- la))))) (defun B-F-PLUS (bnum fnum) (declare (fixnum fnum)) ; ;what gets called when mixed mode occurs ; (if (= fnum *:min-fixnum) (b-difference bnum (let ((tmp (make-bignum 2))) (vset tmp 1 1) tmp)) (let* ((temp (make-bignum 1))) (vset temp 0 (abs fnum)) (if (plusp fnum) (b-plus temp bnum) (b-difference bnum temp))))) (defun B-F-DIFFERENCE (bnum fnum) (declare (fixnum fnum)) ; ;what gets called when mixed mode occurs ; (if (= fnum *:min-fixnum)(b-plus bnum (let ((tmp (make-bignum 2))) (vset tmp 1 1) tmp)) (b-f-plus bnum (- fnum)))) (defun B-F-TIMES (bnum fnum) (declare (fixnum fnum)) ; ;again a mixed mode routine.... ; (let ((la (vector-length bnum))) (declare (fixnum la)) (zap-zeros (if (= fnum *:min-fixnum) (b-negate (vector-replace (make-bignum (1+ la)) bnum 1 0 la)) (b-mult-1 (abs fnum) bnum la (make-bignum (1+ la)) 0) ) (1+ la)))) (defun B-F-QUOTIENT (bnum fnum) (declare (fixnum fnum)) ; ;again a mixed mode routine, though note that for division ;it is a win to use a a different method rather than patch ;the fixnum to look like a bignum for the non-mixed variety. ; (let* ((ftnum (abs fnum)) (dval 0) (s1 (b-plusp bnum)) (s2 (plusp fnum))) (declare (fixnum ftnum dval)) (if (zerop ftnum) (error 'div-by-zero) t) (setq dval (find-d ftnum)) (b-set-sign (if (= 1 dval) (b-f-quotient-1 bnum ftnum) (b-f-quotient-1 (b-f-times bnum dval)(* ftnum dval))) (if (or (and s1 s2)(and (not s1)(not s2))) 1 -1)))) (defun B-F-QUOTIENT-1 (bnum1 ftnum1) (declare (fixnum ftnum1)) ; ;utility for above ; (let* ((la (vector-length bnum1)) (tmpv1 (make-bignum la)) (wordv (make-bignum 3))) (declare (fixnum la)) (do ((i (1- la)(1- i))) ((< i 0) ; (prog () ; (if (boundp bignum-remainder-value) ; t (setq bignum-remainder-value (vref wordv 1))) ; (return (zap-zeros tmpv1 la)) ;)) (vset wordv 0 (vref bnum1 i)) (vset tmpv1 i (b-div-1-1 (vref wordv 1)(vref wordv 0) ftnum1)) (vset wordv 1 (boole 1 *:max-bignum-digit (- (vref wordv 0) (boole 1 (* (vref tmpv1 i) ftnum1) *:max-bignum-digit)))) ;last time through wordv 1 has the remainder ))) (defun b-cnvrt (b-string istart this-long) (declare (fixnum istart this-long)) ; ;all this does is take a sequence of chars and returns as a fixnum ;what they represent. ; (let* ((tmp-sum 0)) (declare (fixnum tmp-sum)) (cond ((zerop this-long) 0) (t (setq tmp-sum (digit-cnvrt (char b-string istart))) (do ((i (1+ istart) (1+ i))(ipt 1 (1+ ipt))) ((not (< ipt this-long)) tmp-sum) (setq tmp-sum (+ (* tmp-sum standard-input-radix) (digit-cnvrt (char b-string i))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; NON-PRIMITIVE PRIMITIVES ;;; ;;; ;;; ;;;Here is where to come once a general arithmetic operation has been ;;; ;;;chopped up to binary functions, mixed modes have been hacked, etc. ;;; ;;;These might reasonably stay Nil compiled code in the system rather ;;; ;;;than being custom coded.... again, the choice depends upon the ;;; ;;;power of the instruction set being utilized in a shop, and the ;;; ;;;ambition of that shop's hackers. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun B-PLUS (numa numb) ; ;nil bignums in this package are stored as signed magnitude, ;thus, this is where the signs get sorted out. ;while this does require that legitimate bignums be input, ;not much checking is done on return to find fixnum size results. ; (let ((s1 (b-plusp numa)) (s2 (b-plusp numb))) (if (or (and s1 s2)(and (not s1)(not s2))) (if s1 (b-set-sign (b-plus-2 numa numb) 1) (b-set-sign (b-plus-2 numa numb) -1)) (if (b-abs-greaterp numb numa) (if s2 (b-set-sign (b-difference-2 numb numa) 1) (b-set-sign (b-difference-2 numb numa) -1)) (if s1 (b-set-sign (b-difference-2 numa numb) 1) (b-set-sign (b-difference-2 numa numb) -1)))))) (defun B-DIFFERENCE (numa numb) (let ((s1 (b-plusp numa))(s2 (b-plusp numb))) (if (not (or (and s1 s2)(and (not s1)(not s2)))) (if s1 (b-set-sign (b-plus-2 numa numb) 1) (b-set-sign (b-plus-2 numa numb) -1)) (if s1 (if (b-abs-greaterp numa numb) (b-set-sign (b-difference-2 numa numb) 1) (b-set-sign (b-difference-2 numb numa) -1)) (if (b-abs-greaterp numa numb) (b-set-sign (b-difference-2 numa numb) -1) (b-set-sign (b-difference-2 numb numa) 1)))))) (defun B-TIMES (numa numb) (let ((s1 (b-plusp numa)) (s2 (b-plusp numb)) (temp-var (b-times-2 numa numb))) (if (or (and s1 s2)(and (not s1)(not s2))) (b-set-sign temp-var 1) (b-set-sign temp-var -1)))) (defun B-QUOTIENT (numa numb) (let ((s1 (b-plusp numa)) (s2 (b-plusp numb)) (temp-var 0)) (cond ((b-equal numa numb) (let ((tmp (make-bignum 1)))(vset tmp 0 1)tmp)) ((b-greaterp numb numa) (let ((tmp (make-bignum 1)))tmp)) (t (setq temp-var (b-quotient-2 numa numb)) (if (or (and s1 s2)(and (not s1)(not s2))) (b-set-sign temp-var 1) (b-set-sign temp-var -1)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; BIGNUM I/O ;;; ;;; The following are unsorted w.r.t. recommendations about custom ;;; ;;; coding, however, there are some obvious candidates for this ;;; ;;; treatment. Announce-radix-flag will ( when set to true ) ;;; ;;; print the fancy radix info at each bignum output. ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun bignum-print (num) (let ((tmp-str (bignum-stringify num)) (*nopoint t)) (if (not (b-plusp num)) (ouch ~/- ) ()) (if (not (null announce-radix-flag)) (if (not (or (= standard-output-radix 2) (= standard-output-radix 8) (= standard-output-radix 16) (= standard-output-radix 10))) (let () (ouch ~/#) (princ standard-output-radix) (ouch ~/r)) (cond ((= standard-output-radix 10) t) ((= standard-output-radix 2) (ouch ~/#)(ouch ~/b)) ((= standard-output-radix 8) (ouch ~/#)(ouch ~/o)) ((= standard-output-radix 16) (ouch ~/#)(ouch ~/x)))) t) (do ((i (1- (string-length tmp-str))(1- i))) ((< i 0)num) (ouch (char tmp-str i))) num)) (defun b-ouchs (n-power fnum b-out-string o-index) ; add stream later (declare (fixnum n-power fnum o-index)) (let* ((b-digits-string "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ") (num-d 0)) (declare (fixnum num-d)) (do ((k (1- n-power) (1- k))) ((= k 0) (rplachar b-out-string o-index (char b-digits-string fnum))) (setq num-d (// fnum (^ standard-output-radix k))) (setq fnum (\ fnum (^ standard-output-radix k))) (rplachar b-out-string (+ k o-index)(char b-digits-string num-d))))) (defun bignum-stringify (num) (let* ((n-power (get-b-power standard-output-radix)) (n-chopper (^ standard-output-radix n-power)) (temp-num num) (lboz (predict-length (vector-length num) standard-output-radix)) (b-output-string (make-string lboz))) (declare (fixnum n-power n-chopper lboz)) (zap-zeros-string (if (= 0 (boole 1 n-chopper *:max-bignum-digit)) (do ((i 0 1) (k7 0 (1+ k7)) (out-index 0 (+ out-index n-power))) ((= k7 (vector-length temp-num)) (progn (set-string-length b-output-string (1+ out-index)) b-output-string)) (b-ouchs n-power (vref temp-num k7) b-output-string out-index)) (let ((frob-digit 0)) (do ((out-index 0 (+ out-index n-power))) ((= 1 (vector-length temp-num)) (progn (b-ouchs n-power (\ (vref temp-num 0) n-chopper) b-output-string out-index) (setq out-index (+ out-index n-power)) (cond ((plusp (// (vref temp-num 0) n-chopper)) (b-ouchs n-power (// (vref temp-num 0) n-chopper) b-output-string out-index) (setq out-index (+ out-index n-power))) (t nil)) (set-string-length b-output-string (1+ out-index)) b-output-string)) (setq frob-digit (vref temp-num 0)) (setq temp-num (b-f-quotient temp-num n-chopper)) (b-ouchs n-power (boole 1 *:max-bignum-digit (- frob-digit (* (vref temp-num 0)n-chopper))) b-output-string out-index))))))) (defun get-b-power (r) (declare (fixnum (get-b-power) r)) ; make this something faster ... table look up? (do ((i 1 (1+ i))) ((> (^ r i) (^ 2 (1- *:bignum-bits-per-word)))(1- i)))) (defun predict-length (nlen r);this should be made sharper (declare (fixnum nlen r)) (* nlen (1- *:bignum-bits-per-word) (1+ (ifix (//$ (log 2.0) (log r)))))) (defun zap-zeros-string (str) (let ((s1 (string-length str))) (declare (fixnum s1)) (do ((i (1- s1) (1- i))) ((not (or (eq (char str i) ~/0)(= (char-n str i) 0))) (set-string-length str (1+ i)) )) str)) (defun bignum-input (b-string b-sign) (declare (fixnum b-sign)) (let* ((n-power (get-b-power standard-input-radix)) (horner (^ standard-input-radix n-power)) (s1 (string-length b-string)) (iter-cdr (\ s1 n-power)) (temp-sum (let ((tmp (make-bignum 1))) (vset tmp 0 (b-cnvrt b-string 0 iter-cdr))tmp))) (declare (fixnum n-power s1 iter-cdr)) (b-set-sign (do ((i iter-cdr (+ i n-power))) ((= s1 i)temp-sum) (setq temp-sum (b-f-plus (b-f-times temp-sum horner)(b-cnvrt b-string i n-power)))) b-sign))) (defun digit-cnvrt (lit) (declare (fixnum (digit-cnvrt))) ;how about digitp when its in, hmmm? (let ((long-frob "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")) (do ((i 0 (1+ i))) ((or (= i 36)(eq lit (char long-frob i))) (if (= i 36) (error) i))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; ;;; EXPONENTS ;;; ;;; Provided are routines for fixnum to exponent and bignum to ;;; ;;; to exponent. Exponents here are always fixnums here! ;;; ;;; ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun b-expt-guts (num orig-num word n-sig-bits) (declare (fixnum word n-sig-bits)) (let* ((temp num)) (do ((i (1- n-sig-bits) (1- i))(old-word word word)) ((< i 0)temp) (setq word (boole 1 word (1- (^ 2 i)))) (if (= word old-word) (setq temp (b-times temp temp)) (setq temp (b-times orig-num (b-times temp temp))))))) (defun b-expt-2 (bnum fnum) (declare (fixnum fnum)) (let* ((s-digits (find-high-d fnum)) (fnum (boole 1 fnum (1- (^ 2 s-digits))))) (declare (fixnum s-digits)) (b-expt-guts bnum bnum fnum s-digits))) (defun b-f-expt-2 (num fnum) (declare (fixnum fnum)) (let* ((tmp (let ((tmp1 (make-bignum 1)))(vset tmp1 0 num)tmp1)) (s-digits (find-high-d fnum)) (fnum (boole 1 fnum (1- (^ 2 s-digits))))) (declare (fixnum s-digits)) (b-expt-guts-1 tmp num fnum s-digits))) (defun b-expt-guts-1 (num orig-num word n-sig-bits) (declare (fixnum word n-sig-bits)) (let* ((temp num)) (do ((i (1- n-sig-bits) (1- i))(old-word word word)) ((< i 0)temp) (setq word (boole 1 word (1- (^ 2 i)))) (if (= word old-word) (setq temp (b-times temp temp)) (setq temp (b-f-times (b-times temp temp) orig-num )))))) u;;; ZEVAL -*-Package:EVAL; Mode:LISP-*- (DECLARE (SPECIAL **ENV** **FNENV** **EXIT** **WIN** **PROG-ENV** **INITIALIZED** /P T NIL)) ;;; MACRO is used instead of DEFMACRO, in order to avoid the ;;; |forget-macromemos/|| eval-mungeable that DEFMACRO generates. #-NIL (MACRO DEF-OPEN-CODED (X) `(DEFUN ,@(CDR X))) ;;; Functions for creating functions (DEF-OPEN-CODED INTERPRETER (X) (GET X 'INTERPRETER)) (DEF-OPEN-CODED SET-INTERPRETER (X FUN) (PUT X 'INTERPRETER FUN)) (DEF-OPEN-CODED MACRO-DEFINITION (X) (GET X 'MACRO)) (DEF-OPEN-CODED SET-MACRO-DEFINITION (X FUN) (PUT X 'MACRO FUN)) (DEF-OPEN-CODED CLOSUREP (FUN) (AND (PAIRP FUN) (EQ (CAR FUN) '&CLOSURE))) (DEFUN MAKE-CLOSURE (ENV FNENV TEMPLATE NAME) (LET ((FROB (LIST* '&CLOSURE ENV FNENV TEMPLATE))) (IF **WIN** (LET ((PROC (SI:COPY-SUBR (FUNCTION SI:ITRAP-SUBR)))) (SET-SUBR-DESCRIPTOR PROC FROB) (SET-SUBR-NAME PROC NAME) (SET-SUBR-DOCUMENTATION PROC "A closure") PROC) FROB))) (DEFUN ZFSYMEVAL (SYM) (COND ((OR **WIN** (FBOUNDP SYM)) (FSYMEVAL SYM)) ((GET SYM 'EXPR)) (T (LET ((FUN (CERROR T () ':UNBOUND-FUNCTION "~S is undefined - ZFSYMEVAL" SYM))) (ZFSET SYM FUN) FUN)))) (DEFUN ZFSET (SYM VAL) (COND (**WIN** (FSET SYM VAL)) ((SUBRP VAL) (FSET SYM VAL)) (T (PUT SYM 'EXPR VAL)))) ;;; ZEVAL, ENCLOSE (DEFUN ZEVAL (EXP) (LET ((**ENV** '**NULL-ENV**) (**FNENV** '**NULL-FNENV**) **PROG-ENV**) (INTERNAL-EVAL EXP ()))) (DEFUN INTERNAL-EVAL (EXP FNP) (COND ((PAIRP EXP) (LET ((C (CAR EXP))) (IF (SYMBOLP C) (LET ((INT (INTERPRETER C))) (IF INT (FUNCALL INT EXP) (LET ((MAC (MACRO-DEFINITION C))) (IF MAC (INTERNAL-EVAL (ZAPPLY MAC `(,EXP)) FNP) (ZAPPLY (INTERNAL-EVAL C T) (EVAL-LIST (CDR EXP))))))) (ZAPPLY (INTERNAL-EVAL C T) (EVAL-LIST (CDR EXP)))))) ((SYMBOLP EXP) (IF FNP (LET ((B (LOOKUP EXP **FNENV**))) (IF B (CDR B) (ZFSYMEVAL EXP))) (LET ((B (LOOKUP EXP **ENV**))) (IF B (CDR B) (SYMEVAL EXP))))) (T EXP))) ;;; (MAPCAR #'EVAL L) (DEFUN EVAL-LIST (L) (DO ((L L (CDR L)) (M () (CONS (INTERNAL-EVAL (CAR L) ()) M))) ((NULL L) (ZREAD-NREVERSE M)))) ;;; Evaluate a list of forms, and return the value of the last. (DEFUN EVAL-SEQ (L) (DO ((L L (CDR L)) (VAL '() (INTERNAL-EVAL (CAR L) ()))) ;(CAR '()) => '() ((NULL L) VAL))) (DEFUN ENCLOSE (LAMBDA-EXPRESSION) (DO () ((AND (PAIRP LAMBDA-EXPRESSION) (EQ (CAR LAMBDA-EXPRESSION) 'LAMBDA))) (SETQ LAMBDA-EXPRESSION (CERROR T () ':WRONG-TYPE-ARGUMENT 'LAMBDA-EXPRESSION LAMBDA-EXPRESSION))) (MAKE-CLOSURE '**ENCLOSURE-ENV** '**ENCLOSURE-FNENV** (CDR LAMBDA-EXPRESSION) '*ENCLOSURE*)) ;;; ZAPPLY, BIND-ARGS, LOOKUP (DEFUN ZAPPLY (FUN ARGS) (COND ((CLOSUREP FUN) ;; FUN should be of the form (&PROCEDURE env fnenv args . body) (POP FUN) (LET ((**ENV** (POP FUN)) (**FNENV** (POP FUN))) (BIND-ARGS (POP FUN) ARGS) ;Side-effects (EVAL-SEQ FUN))) (T (ZAPPLY-SUBR FUN ARGS)))) (DEFUN ZAPPLY-SUBR (FUN ARGS) (CASEQ (LENGTH ARGS) ((0) (FUNCALL FUN)) ((1) (FUNCALL FUN (ELT ARGS 0))) ((2) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1))) ((3) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1) (ELT ARGS 2))) ((4) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1) (ELT ARGS 2) (ELT ARGS 3))) ((5) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1) (ELT ARGS 2) (ELT ARGS 3) (ELT ARGS 4))) ((6) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1) (ELT ARGS 2) (ELT ARGS 3) (ELT ARGS 4) (ELT ARGS 5))) ((7) (FUNCALL FUN (ELT ARGS 0) (ELT ARGS 1) (ELT ARGS 2) (ELT ARGS 3) (ELT ARGS 4) (ELT ARGS 5) (ELT ARGS 6))) (T (FERROR () "~S ~S You lose! APPLY can't hack it!" FUN ARGS)))) ;;; This should be haired up to interface correctly with compiled code ;;; (ARGS might be a VECTOR-S!) (DEFUN BIND-ARGS (BVL ARGS) (DO ((ARGS-LENGTH (LENGTH ARGS)) (I 0 (1+ I)) (B BVL (CDR B))) ((NULL B) (COND ((NOT (= I ARGS-LENGTH)) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too many arguments supplied" BVL ARGS)))) (COND ((= I ARGS-LENGTH) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too few arguments supplied" BVL ARGS))) (LET ((SPEC (CAR B)) (ARG (ELT ARGS I))) (COND ((PAIRP SPEC) (CASEQ (CAR SPEC) ((&FUNCTION) (PUSH (CONS (CADR SPEC) ARG) **FNENV**)) ((&VARIABLE) (PUSH (CONS (CADR SPEC) ARG) **ENV**)) (T (FERROR () "~S bad LAMBDA list syntax" BVL)))) (T (PUSH (CONS SPEC ARG) **ENV**)))))) ;;; Environments are maintained as simple a-lists. (DEFUN LOOKUP (SYM ENV) (DO ((E ENV (CDR E))) ((ATOM E) ()) (LET ((B (CAR E))) (IF (EQ SYM (CAR B)) (RETURN B))))) ;;; Special forms (EVAL-WHEN (EVAL COMPILE) (SETQ *SPECIAL-FORM-INITS* '())) (MACRO DEFINE-SPECIAL-FORM (X) (LET ((NAME (CADR X)) (Z (CDDR X))) (LET ((X (SYMBOLCONC NAME '-SPECIAL-FORM-FUNCTION))) (OR (ASSQ NAME *SPECIAL-FORM-INITS*) (PUSH (CONS NAME X) *SPECIAL-FORM-INITS*)) `(DEFUN ,X . ,Z)))) (MACRO THE-SPECIAL-FORM-INITS (()) ;; No MAPC for now. `(DO ((L ',(REVERSE *SPECIAL-FORM-INITS*) (CDR L))) ((NULL L)) (SET-INTERPRETER (CAAR L) (FSYMEVAL (CDAR L))))) (DEFINE-SPECIAL-FORM MACRO (FORM) (LET ((SYM (CADR FORM))) (SET-MACRO-DEFINITION SYM (MAKE-CLOSURE '**MACRO-ENV** '**MACRO-FNENV** (CDDR FORM) SYM)) (SET-INTERPRETER SYM #'INTERPRET-MACRO-FORM) SYM)) (DEFUN INTERPRET-MACRO-FORM (FORM) (LET ((M (MACRO-DEFINITION (CAR FORM)))) (IF M (INTERNAL-EVAL (FUNCALL M FORM) ()) (CERROR T () ':UNDEFINED-FUNCTION "No macro definition for ~S" (CAR FORM))))) (DEFINE-SPECIAL-FORM DEFUN (FORM) (LET ((SYM (CADR FORM))) (ZFSET SYM (MAKE-CLOSURE '**DEFUN-ENV** '**DEFUN-FNENV** (CDDR FORM) SYM)) SYM)) (DEFINE-SPECIAL-FORM LAMBDA (FORM) (MAKE-CLOSURE **ENV** **FNENV** (CDR FORM) '*CLOSURE*)) ;;; ... and more of the same. (DEFINE-SPECIAL-FORM SETQ (FORM) (DO ((L (CDR FORM) (CDDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CADR L) ())) (LET ((B (LOOKUP (CAR L) **ENV**))) (IF B (RPLACD B VAL) (SET (CAR L) VAL))))) (DEFINE-SPECIAL-FORM FSETQ (FORM) (DO ((L (CDR FORM) (CDDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CADR L) ())) (LET ((B (LOOKUP (CAR L) **FNENV**))) (IF B (RPLACD B VAL) (ZFSET (CAR L) VAL))))) (DEFINE-SPECIAL-FORM COMMENT (EXP) (CAR EXP)) (DEFINE-SPECIAL-FORM DECLARE (EXP) (CAR EXP)) ;Yeah, I know... (DEFINE-SPECIAL-FORM QUOTE (EXP) (CADR EXP)) (DEFINE-SPECIAL-FORM FUNCTION (EXP) (INTERNAL-EVAL (CADR EXP) T)) (DEFINE-SPECIAL-FORM AND (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CAR L) ())) (COND ((NOT VAL) (RETURN ()))))) (DEFINE-SPECIAL-FORM OR (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) ()) (SETQ VAL (INTERNAL-EVAL (CAR L) ())) (COND (VAL (RETURN VAL))))) (DEFINE-SPECIAL-FORM IF (EXP) (IF (INTERNAL-EVAL (CADR EXP) ()) (INTERNAL-EVAL (CADDR EXP) ()) (INTERNAL-EVAL (CADDDR EXP) ()))) (DEFINE-SPECIAL-FORM COND (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) ()) (SETQ VAL (INTERNAL-EVAL (CAAR L) ())) (COND ((NOT VAL)) ((NULL (CDAR L)) (RETURN VAL)) (T (RETURN (EVAL-SEQ (CDAR L))))))) ;;; RETURN, GO, DO, PROG (DEFINE-SPECIAL-FORM RETURN (EXP) (DOLIST (ENV **PROG-ENV**) (UNLESS (EQ (CAR ENV) 'T) (*THROW 'SI:DORETURN `(,(CAR ENV) ,(INTERNAL-EVAL (CADR EXP) ()))))) (FERROR () "RETURN not inside DO or PROG")) (DEFINE-SPECIAL-FORM RETURN-FROM (EXP) (LET (((RETURN-FROM NAME VAL) EXP)) RETURN-FROM (DOLIST (ENV **PROG-ENV**) (WHEN (EQ NAME (CAR ENV)) (*THROW 'SI:DORETURN `(,NAME ,(INTERNAL-EVAL VAL ()))))) (FERROR () "~S RETURN-FROM name not found" NAME))) (DEFINE-SPECIAL-FORM GO (EXP) (CASEQ (LENGTH EXP) (2 (LET ((TAG (CADR EXP))) (DOLIST (PROG-ENV **PROG-ENV**) (UNLESS (EQ (CAR PROG-ENV) 'T) (LET ((FOUND (MEMQ TAG (CADR PROG-ENV)))) (WHEN FOUND (*THROW 'SI:DOGO `(,(CAR PROG-ENV) ,FOUND)))))) (FERROR () "~S Unseen GO tag" TAG))) (3 (LET (((GO NAME TAG) EXP)) GO (LET ((PROG-ENV (ASSQ NAME **PROG-ENV**))) (IF (NULL PROG-ENV) (FERROR () "~S Unseen PROG name" NAME) (LET ((FOUND (MEMQ TAG (CADR PROG-ENV)))) (IF FOUND (*THROW 'SI:DOGO `(,NAME ,TAG)) (FERROR () "~S Unseen GO tag for name ~S" TAG NAME))))))) (T (FERROR () "~S Badly-formed GO" EXP)))) (DEFINE-SPECIAL-FORM DO (EXP) (COND ((LISTP (CADR EXP)) (LET (((DO VARS PREDL . BODY) EXP)) DO (INTERPRET-DO () VARS PREDL BODY))) ((SYMBOLP (CADR EXP)) (LET (((DO VAR INIT STEP PRED . BODY) EXP)) DO (INTERPRET-DO () `((,VAR ,INIT ,STEP)) `(,PRED) BODY))) (#T (FERROR () "~S Bad var list in DO" (CADR EXP))))) (DEFINE-SPECIAL-FORM DO-NAMED (EXP) (LET (((DO NAME VARS PREDL . BODY) EXP)) DO (INTERPRET-DO NAME VARS PREDL BODY))) (DEFINE-SPECIAL-FORM PROG (EXP) (LET (NAME ((PROG VARL . BODY) EXP)) PROG (WHEN (AND VARL (SYMBOLP VARL)) ;Named PROG? (SETQ NAME VARL VARL (CAR BODY) BODY (CDR BODY))) (INTERPRET-DO NAME ;Can't (MAPCAR #'(LAMBDA (X) (LIST X)) VARL) yet (DO ((VARL VARL (CDR VARL)) (L)) ((NULL VARL) (NREVERSE L)) (PUSH (LIST (CAR VARL)) L)) () BODY))) (DEFUN INTERPRET-DO (DONAME VARSPECS PREDL BODY) (DO ((SPECS VARSPECS (CDR SPECS)) (ENV **ENV**) (FNENV **FNENV**)) ((NULL SPECS) (LET ((**ENV** ENV) (**FNENV** FNENV) (**PROG-ENV** (CONS `(,DONAME ,BODY) **PROG-ENV**))) (INTERPRET-DOBODY DONAME VARSPECS PREDL BODY))) ---- (LET (((VAR INIT STEP) (CAR SPECS))) STEP (COND ((NULL VAR) (INTERNAL-EVAL INIT ())) ((SYMBOLP VAR) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT ())) ENV)) ((ATOM VAR) (FERROR () "~S Bad variable in DO" VAR)) ((EQ (CAR VAR) '&VARIABLE) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT ())) ENV)) ((EQ (CAR VAR) '&FUNCTION) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT #T)) FNENV)) (#T (FERROR () "~S Bad variable in DO" VAR)))) ---)) (DEFUN INTERPRET-DOBODY (DONAME VARSPECS PREDL BODY) (LET (((RETNAME RETVAL) (*CATCH 'SI:DORETURN (DO ((NOT-1ST () #T)) ((AND PREDL (INTERNAL-EVAL (CAR PREDL) ())) `(,DONAME ,(EVAL-SEQ (CDR PREDL)))) ---- (WHEN (AND NOT-1ST (NULL PREDL)) (RETURN `(,DONAME ()))) (DO ((BOD BODY) (GOFOO)) ((NOT (SETQ GOFOO (*CATCH 'SI:DOGO (DOLIST (ITEM BOD) (UNLESS (ATOM ITEM) (INTERNAL-EVAL ITEM ()))))))) ---- (LET (((NAME GOBOD) GOFOO)) (COND ((NOT (EQ NAME DONAME)) (*THROW 'SI:DOGO GOFOO)) (#T (SETQ BOD GOBOD)))) ---) (STEP-DO-VARSPECS VARSPECS) ---)))) (IF (EQ RETNAME DONAME) RETVAL (*THROW 'SI:DORETURN `(,RETNAME ,RETVAL))))) (DEFUN STEP-DO-VARSPECS (VARSPECS) (DO ((VARS) (VALS) (FNVARS) (FNVALS) (SPECS VARSPECS (CDR SPECS))) ((NULL SPECS) (DO ((VARS VARS (CDR VARS)) (VALS VALS (CDR VALS)) (VAR) (VAL)) ((OR (NULL VARS) (NULL VALS))) (SETQ VAR (CAR VARS) VAL (CAR VALS)) (LET ((B (LOOKUP (IF (ATOM VAR) VAR (CADR VAR)) **ENV**))) (IF B (RPLACD B VAL) (SET (IF (ATOM VAR) VAR (CADR VAR)) VAL)))) (DO ((FNVARS FNVARS (CDR FNVARS)) (FNVAR) (FNVALS FNVALS (CDR FNVALS)) (FNVAL)) ((OR (NULL FNVARS) (NULL FNVARS))) (SETQ FNVAR (CAR FNVARS) FNVAL (CAR FNVALS)) (LET ((B (LOOKUP (CADR FNVAR) **FNENV**))) (IF B (RPLACD B FNVAL) (ZFSET (CADR FNVAR) FNVAL)))) #T) ---- (LET (((VAR INIT . STEPP) (CAR SPECS))) INIT (COND (STEPP ;Stepper present (COND ((NULL VAR)) ((AND (PAIRP VAR) (EQ (CAR VAR) '&FUNCTION)) (PUSH VAR FNVARS) (PUSH (INTERNAL-EVAL (CAR STEPP) #T) FNVALS)) (#T (PUSH VAR VARS) (PUSH (INTERNAL-EVAL (CAR STEPP) ()) VALS)))))) ---)) ;;; CASEQ (DEFINE-SPECIAL-FORM CASEQ (EXP) (LET ((KEY (INTERNAL-EVAL (CADR EXP) ()))) (EVAL-CASEQ (TYPE-OF KEY) KEY (CDDR EXP)))) (DEFINE-SPECIAL-FORM TYPECASEQ (EXP) (EVAL-CASEQ 'SYMBOL (TYPE-OF (INTERNAL-EVAL (CADR EXP) ())) (CDDR EXP))) ;;; This definition depends on FIXNUMs being EQ to themselves in real Nil. (DEFUN EVAL-CASEQ (TYPE KEY CLAUSES) (DOLIST (CLAUSE CLAUSES) (WHEN (OR (MEMQ (CAR CLAUSE) '(T #T)) (CASEQ-CASE-MATCH? TYPE KEY (CAR CLAUSE))) (RETURN (EVAL-SEQ (CDR CLAUSE)))))) (DEFUN CASEQ-CASE-MATCH? (TYPE KEY KEY?S) (IF (ATOM KEY?S) (COND ((EQ KEY KEY?S) #T) ((EQ (TYPE-OF KEY?S) TYPE) ()) (#T (FERROR () "~S CASEQ key not of type ~S" KEY?S TYPE))) (DOLIST (K KEY?S) (COND ((EQ KEY K) (RETURN #T)) ((EQ (TYPE-OF K) TYPE) ()) (#T (FERROR () "~S CASEQ key not of type ~S" K TYPE)))))) (DEFINE-SPECIAL-FORM PROGN (EXP) (EVAL-SEQ (CDR EXP))) (DEFINE-SPECIAL-FORM PROG1 (EXP) (LET ((VAL (INTERNAL-EVAL (CADR EXP) ()))) (EVAL-SEQ (CDDR EXP)) VAL)) (DEFINE-SPECIAL-FORM PROG2 (EXP) (INTERNAL-EVAL (CADR EXP) ()) (LET ((VAL (INTERNAL-EVAL (CADDR EXP) ()))) (EVAL-SEQ (CDDDR EXP)) VAL)) ;;; Initialization and top-level (DEFUN INIT-ZEVAL () (DECLARE (SPECIAL PACKAGE)) (SETQ **ENV** '**TOP-LEVEL-ENV**) (SETQ **FNENV** '**TOP-LEVEL-FNENV**) (SETQ /P (SETQ **EXIT** '**EXIT**)) (SETQ **WIN** ()) ;(FBOUNDP 'SI:APPLY-SUBR) #+NIL (FSETQ EVAL #'ZEVAL APPLY #'ZAPPLY READ #'ZREAD PRIN1 #'ZPRIN1 PRINT #'ZPRINT TERPRI #'ZTERPRI NREVERSE #'ZREAD-NREVERSE) #+NIL (SETQ T (NOT ())) #+NIL (SET (SI:RINTERN "NIL" 3 PACKAGE) (NOT 'T)) (THE-SPECIAL-FORM-INITS) (SETQ **INITIALIZED** 'INITIALIZED)) #+NIL (DEFUN APPLY (X Y) (ZAPPLY X Y)) (DEFUN ZREPL () (DECLARE (SPECIAL + - *)) (IF (NOT (AND (BOUNDP '**INITIALIZED**) **INITIALIZED**)) (INIT-ZEVAL)) (DO ((* '* (ZEVAL -)) (- '-) (+ '+ -)) ((EQ * **EXIT**) ":KILL ") (PRINT *) (TERPRI) (SETQ - (READ)))) (DEFUN ZQUIT () **EXIT**) ;;; Crocks for Maclisp #-NIL (PROGN 'COMPILE (DEFUN PUT (SYM PROP VAL) (PUTPROP SYM VAL PROP)) (DEFUN FSYMEVAL (SYM) (LET ((P (GETL SYM '(EXPR SUBR LSUBR)))) (COND ((NULL P) (FERROR ':UNBOUND-FUNCTION "~S has no function binding" SYM)) ((NOT (EQ (CAR P) 'EXPR)) SYM) (T (CADR P))))) (DEFUN FSET (SYM VAL) (PUTPROP SYM VAL 'EXPR)) (DEFUN SI:APPLY-SUBR (X Y) (APPLY X Y)) (DEFUN SI:COPY-SUBR (X) (SUBST () () (COND ((SYMBOLP X) (GET X 'EXPR)) (T X)))) (PUTPROP 'SI:ITRAP-SUBR '(LAMBDA **NARGS** (ZAPPLY '**LOSE** (LISTIFY **NARGS**))) 'EXPR) (DEFUN SET-SUBR-DESCRIPTOR (X Y) (RPLACA (CDR (CADR (CADDR X))) Y)) (DEFUN SET-SUBR-DOCUMENTATION (() ()) ()) (DEFUN SET-SUBR-NAME (() ()) ()) (DEFUN ZREAD-NREVERSE (L) (NREVERSE L)) (DEFUN ELT (X N) (NTH N X)) (DEFUN ZTERPRI () (TERPRI)) (DEFUN ZREAD () (READ)) (DEFUN ZPRINT (X) (PRIN1 X)) (DEFUN SUBRP (X) (OR (EQ (CAR X) 'LAMBDA) (SYMBOLP X))) (DEFUN ZLOAD (F) (LET ((FILE (OPEN F)) (EOF (LIST 'EOF))) (DO ((FORM (READ FILE EOF) (READ FILE EOF))) ((EQ FORM EOF)) (ZEVAL FORM) 'T) (CLOSE FILE))) ) ;End of #-NIL -;;; ZEVAL0 -*-Package:EVAL; Mode:LISP-*- (DECLARE (SPECIAL **ENV** **FNENV** **EXIT** **WIN** **PROG-ENV** **INITIALIZED** /P T NIL)) ;;; MACRO is used instead of DEFMACRO, in order to avoid the ;;; |forget-macromemos/|| eval-mungeable that DEFMACRO generates. #-NIL (MACRO DEF-OPEN-CODED (X) `(DEFUN ,@(CDR X))) #-NIL (DEFUN MACRO-DEFINITION (X) (GET X 'MACRO)) ;;; Functions for creating functions (DEF-OPEN-CODED INTERPRETER (X) (GET X 'INTERPRETER)) (DEF-OPEN-CODED SET-INTERPRETER (X FUN) (PUT X 'INTERPRETER FUN)) (DEF-OPEN-CODED CLOSUREP (FUN) (AND (PAIRP FUN) (EQ (CAR FUN) '&CLOSURE))) (DEFUN MAKE-CLOSURE (ENV FNENV TEMPLATE NAME) (LET ((FROB (LIST* '&CLOSURE ENV FNENV TEMPLATE))) (IF **WIN** (LET ((PROC (SI:COPY-SUBR (FUNCTION SI:ITRAP-SUBR)))) (SET-SUBR-DESCRIPTOR PROC FROB) (SET-SUBR-NAME PROC NAME) (SET-SUBR-DOCUMENTATION PROC "A closure") PROC) FROB))) #+NIL (FSETQ ZFSYMEVAL #'FSYMEVAL) (DEFUN ZFSET (SYM VAL) (COND (**WIN** (FSET SYM VAL)) ((SUBRP VAL) (FSET SYM VAL)) (#T (PUT SYM 'EXPR VAL)))) ;;; ZEVAL, ENCLOSE (DEFUN ZEVAL (EXP) (LET ((**ENV** '**NULL-ENV**) (**FNENV** '**NULL-FNENV**) **PROG-ENV**) (INTERNAL-EVAL EXP ()))) (DEFUN INTERNAL-EVAL (EXP FNP) (COND ((PAIRP EXP) (LET ((C (CAR EXP))) (IF (SYMBOLP C) (LET ((INT (INTERPRETER C))) (IF INT (FUNCALL INT EXP) (LET ((MAC (MACRO-DEFINITION C))) (IF MAC (INTERNAL-EVAL (FUNCALL MAC EXP) FNP) (INTERNAL-EVAL-SEQ-AND-APPLY C (CDR EXP)) )))) (INTERNAL-EVAL-SEQ-AND-APPLY C (CDR EXP))))) ((SYMBOLP EXP) (IF FNP (INTERPRETER-FSYMEVAL EXP) (INTERPRETER-SYMEVAL EXP))) (#T EXP))) ;;; (MAPCAR #'EVAL L) ;(DEFUN EVAL-LIST (L) ; (DO ((L L (CDR L)) ; (M () (CONS (INTERNAL-EVAL (CAR L) ()) M))) ; ((NULL L) (ZREAD-NREVERSE M)))) (DEFUN INTERNAL-EVAL-SEQ-AND-APPLY (FN SEQ) (SI:FUNCALL-EXTRA-NULLS #'INTERNAL-EVAL-SEQ-AND-APPLY-1 (INTERNAL-EVAL FN #T) SEQ (LIST-LENGTH SEQ))) (DEFUN INTERNAL-EVAL-SEQ-AND-APPLY-1 (FUN SEQ &RESTV SEQV) (DOLIST (FORM SEQ I) (VSET SEQV I (INTERNAL-EVAL FORM ()))) (ZAPPLY FUN SEQV)) ;;; Evaluate a list of forms, and return the value of the last. (DEFUN EVAL-SEQ (L) (DO ((L L (CDR L)) (VAL '() (INTERNAL-EVAL (CAR L) ()))) ;(CAR '()) => '() ((NULL L) VAL))) (DEFUN ENCLOSE (LAMBDA-EXPRESSION) (DO () ((AND (PAIRP LAMBDA-EXPRESSION) (EQ (CAR LAMBDA-EXPRESSION) 'LAMBDA))) (SETQ LAMBDA-EXPRESSION (CERROR #T () ':WRONG-TYPE-ARGUMENT 'LAMBDA-EXPRESSION LAMBDA-EXPRESSION))) (MAKE-CLOSURE '**ENCLOSURE-ENV** '**ENCLOSURE-FNENV** (CDR LAMBDA-EXPRESSION) '*ENCLOSURE*)) ;;; ZAPPLY (DEFUN ZAPPLY (FUN ARGS) (COND ((CLOSUREP FUN) ;; FUN should be of the form (&PROCEDURE env fnenv args . body) (POP FUN) (LET (;;(**PROG-ENV** ()) (**ENV** (POP FUN)) (**FNENV** (POP FUN))) (IF (VECTORP ARGS) (BIND-ARGS (POP FUN) ARGS) (LEXPR-FUNCALL #'BIND-ARGS-LIST (POP FUN) ARGS)) ;Side-effects (EVAL-SEQ FUN))) ((PAIRP FUN) (COND ((EQ (CAR FUN) 'LAMBDA) (POP FUN) (LET ((**ENV** '**NULL-ENV**) (**FNENV** '**NULL-FNENV**)) (IF (VECTORP ARGS) (BIND-ARGS (POP FUN) ARGS) (LEXPR-FUNCALL #'BIND-ARGS-LIST (POP FUN) ARGS)) (EVAL-SEQ FUN))) (#T (ZAPPLY (CERROR '#T () ':WRONG-TYPE-ARGUMENT "Can't apply non-function ~S" FUN) ARGS)))) (#T (LEXPR-FUNCALL FUN (IF (PAIRP ARGS) ;Poor VM can't hack lists (TO-VECTOR ARGS) ARGS))))) (defvar *break-level* 0 "Count of recursive break levels") (DEFUN ZREPL (&OPTIONAL BREAKP) (DECLARE (SPECIAL + ++ +++ - * ** *** **INITIALIZED**)) (IF (NOT (AND (BOUNDP '**INITIALIZED**) **INITIALIZED**)) (INIT-ZEVAL)) (let ((*break-level* *break-level*) (read-prompt "")) (when breakp (setq *break-level* (1+ *break-level*)) (setq read-prompt (format () "~d>break> " *break-level*))) (DO ((+ (if breakp + '+)) (++ (if breakp ++ '++)) (+++ (if breakp +++ '+++)) (* (if breakp * '*)) (** (if breakp ** '**)) (*** (if breakp *** '***)) (- (if breakp - ''*)) (first #T ()) ) (()) (unless first (if breakp (progn (psetq * (*catch 'break (ZEVAL -)) + - ++ + +++ ++ ** * *** **) (when (eq * **EXIT**) (return ())) (unless first (print *))) (*catch 'ferror (psetq * (*catch '(break si:top-level) (ZEVAL -)) + - ++ + +++ ++ ** * *** **) (when (eq * **EXIT**) (return ())) (print *)))) (TERPRI) (SETQ - (RUBOUT-HANDLER #'READ read-prompt)) (cond ((not breakp)) ((eq - '/P) (terpri) (return ())) ((eq - '/R) (let ((- (rubout-handler #'read "Form to eval and return from the break "))) (*catch 'break (return (zeval -)))))) (TERPRI) ;This TERPRI makes VMS debugger typeout come out ;at the beginning of the line -- VMS types a lf ;first rather than cr/lf. PRINT should use :fresh-line ))) (DEFUN ZQUIT () **EXIT**) ;;; Crocks for Maclisp #-NIL (PROGN 'COMPILE (DEFUN PUT (SYM PROP VAL) (PUTPROP SYM VAL PROP)) (DEFUN SI:APPLY-SUBR (X Y) (APPLY X Y)) (DEFUN SI:COPY-SUBR (X) (IF (EQ X 'SI:ITRAP-SUBR) (SI:MAKE-EXTEND (CLOSURE-SIZE) CLOSURE-CLASS) (FERROR () "SI:COPY-SUBR not from SI:ITRAP-SUBR ~s" X))) (PUTPROP 'SI:ITRAP-SUBR '(LAMBDA **NARGS** (ZAPPLY '**LOSE** (LISTIFY **NARGS**))) 'EXPR) (DEFUN CLOSUREP (X) (EQ (TYPE-OF X) CLOSURE-CLASS)) (DEFUN SUBR-DESCRIPTOR (X) (CLOSURE-FORM X)) (DEFMACRO SUBR-DESCRIPTOR (X) `(CLOSURE-FORM ,X)) (DEFUN SET-SUBR-DESCRIPTOR (X Y) (SETF (SUBR-DESCRIPTOR X) Y)) (DEFUN SET-SUBR-DOCUMENTATION (() ()) ()) (DEFUN SET-SUBR-NAME (() ()) ()) (DEFUN SI:FSYMEVAL-SUBR (SYM) (FSYMEVAL SYM)) (DEFUN ZFSYMEVAL (SYM) ;For Maclisp, must unwrap trampoline (LET ((FUN (SI:FSYMEVAL-SUBR SYM))) (OR (TRAMPOLINE-EXPRP FUN) FUN))) (DEFUN TRAMPOLINE-EXPRP (FUN) (AND (PAIRP FUN) (= (LENGTH FUN) 3) ;(LAMBDA **NARGS** mumble) (EQ (CAR FUN) 'LAMBDA) (EQ (CADR FUN) '**NARGS**) (LET ((MUM (CADDR FUN))) ;(APPLY foo (LISTIFY **NARGS**)) (AND (PAIRP MUM) (EQ (LENGTH MUM) 3) (EQ (CAR MUM) 'ZAPPLY) (EQUAL (CADDR MUM) '(LISTIFY **NARGS**)) (LET ((FOO (CADR MUM)) ) ;(QUOTE thing) (AND (PAIRP FOO) (= (LENGTH FOO) 2) (EQ (CAR FOO) 'QUOTE) (CADR FOO))))))) (DEFUN ZREAD-NREVERSE (L) (NREVERSE L)) (DEFUN ELT (X N) (NTH N X)) (DEFUN ZTERPRI () (TERPRI)) (DEFUN ZREAD () (READ)) (DEFUN ZPRINT (X) (PRIN1 X)) (DEFUN LIST-LENGTH (X) (LENGTH X)) (defmethod* (call subr-class) (self &rest argl) (call-loser 'subrcall self argl)) (defmethod* (call lsubr-class) (self &rest argl) (call-loser 'lsubrcall self argl)) (defun call-loser (fn self argl) (apply fn `(T ',(si:xref self 0) ,@(mapcar #'(lambda (x) `',x) argl)))) (defclass* closure closure-class object-class typep closure) (defmacro closure-size () 1) (defmacro closure-form (x) `(si:xref ,x 0)) (defmethod* (call closure-class) (self &rest argl) (zapply (closure-form self) argl)) (DEFUN ZLOAD (F) (LET ((FILE (OPEN F)) (EOF (LIST 'EOF))) (DO ((FORM (READ FILE EOF) (READ FILE EOF))) ((EQ FORM EOF)) (ZEVAL FORM) 'T) (CLOSE FILE))) (defun si:funcall-extra-nulls (fun &restv args) (let ((n (vector-length (or args #())))) (if (= n 0) (funcall fun) (let ((number (vref args (1- n)))) (do () ((and (fixnump number) (<= 0 number) (<= number 500.))) (setq number (cerror #T () 'out-of-range "SI:FUNCALL-EXTRA-NULLS ~s" number))) (apply fun (do ((l (make-list number)) (i (- n 2) (1- i))) ((< i 0) l) (push (vref args i) l))))))) ) ;End of #-NIL ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; END: ;;; ZEVALB -*-Package:EVAL; Mode:LISP-*- (DECLARE (SPECIAL **ENV** **FNENV** **EXIT** **WIN** **PROG-ENV** **INITIALIZED** /P T NIL)) ;;; Environments are maintained as simple a-lists, in the usual case. ;;; Instance variables are kludged by the car of the "alist" bucket ;;; being the following marker, and the cdr of the bucket is ;;; (var-name the-instance already-mapped-index-into-the-instance) (DEFVAR *INTERPRETER-INSTANCE-VARIABLE-MARKER* (VECTOR 'IIVM)) (DEFUN LOOKUP (SYM ENV) (DO ((E ENV (CDR E))) ((ATOM E) ()) (LET ((B (CAR E))) (WHEN (OR (EQ (CAR B) SYM) (AND (EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (EQ (SECOND B) SYM))) (RETURN B))))) (DEFUN INTERPRETER-SYMEVAL (SYMBOL) (LET ((B (LOOKUP SYMBOL **ENV**))) (COND ((NULL B) (SYMEVAL SYMBOL)) ((EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (LET (((THE-INSTANCE LOC) (REST2 B))) (IF (EQ (SI:XREF THE-INSTANCE LOC) (SI:UNBOUND-MARKER)) (SEND THE-INSTANCE ':UNBOUND-VARIABLE LOC) (SI:XREF THE-INSTANCE LOC)))) (#T (CDR B))))) (DEFUN INTERPRETER-FSYMEVAL (SYMBOL) (LET ((B (LOOKUP SYMBOL **FNENV**))) (COND ((NULL B) (IF (FBOUNDP SYMBOL) (SI:FSYMEVAL-SUBR SYMBOL) (CERROR '#T () ':UNBOUND-FUNCTION "Internal eval finds no function binding for ~s" SYMBOL))) ((EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (LET (((THE-INSTANCE LOC) (REST2 B))) (SI:XREF THE-INSTANCE LOC))) (#T (CDR B))))) (DEFUN INTERPRETER-SET (VAR VAL) (LET ((B (LOOKUP VAR **ENV**))) (COND ((NULL B) (SET VAR VAL)) ((EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (LET (((THE-INSTANCE LOC) (REST2 B))) (SI:XSET THE-INSTANCE LOC VAL))) (#T (RPLACD B VAL))))) (DEFUN INTERPRETER-FSET (VAR VAL) (LET ((B (LOOKUP VAR **FNENV**))) (COND ((NULL B) (ZFSET VAR VAL)) ((EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (LET (((THE-INSTANCE LOC) (REST2 B))) (SI:XSET THE-INSTANCE LOC VAL))) (#T (RPLACD B VAL))))) (DEFUN INTERPRETER-BOUNDP (VAR) (LET ((B (LOOKUP VAR **ENV**))) (COND ((NULL B) (BOUNDP VAR)) ((EQ (CAR B) *INTERPRETER-INSTANCE-VARIABLE-MARKER*) (LET (((THE-INSTANCE LOC) (REST2 B))) (NOT (EQ (SI:XREF THE-INSTANCE LOC) (SI:UNBOUND-MARKER))))) (#T #T)))) (DEFUN BIND-ONE-ARG (BV ARG) (COND ((NULL BV)) ;Ignored variable ((SYMBOLP BV) (IF (KEYWORD-P BV) (FERROR () "~S Unrecognized &keyword" BV) (PUSH (CONS BV ARG) **ENV**))) ((PAIRP BV) (COND ((EQ (CAR BV) '&FUNCTION) (PUSH (CONS (CADR BV) ARG) **FNENV**)) ((EQ (CAR BV) '&VARIABLE) (PUSH (CONS (CADR BV) ARG) **ENV**)) ((KEYWORD-P (CAR BV)) (FERROR () "~S Unrecognized &keyword" BV)) (#T (FERROR () "No LAMBDA list destructuring yet ~s" BV)))) ((VECTORP BV) (FERROR () "No LAMBDA list destructuring yet ~s" BV)) (#T (FERROR () "~S Bad LAMBDA list item" (CAR BV))))) (defun bind-instance-variables (wifi-arg) (let (( (flavor-name info obj-var local-method-map-var . no-specbind) wifi-arg)) ;;Default no-specbind to T (setq no-specbind (if no-specbind (car no-specbind) 'T)) (let ((the-instance (interpreter-symeval obj-var)) (the-meth-map (interpreter-symeval local-method-map-var))) (dolist (v info) (let ((name (car v)) (loc (si:flavor-method-map-var-ref the-meth-map (get v ':slot))) (is-special (get v ':special)) (is-function (get v ':function))) (when (and is-special (not no-specbind)) (ferror ':implementation-lossage "~Can't bind special instance ~:[variable~;function~] ~s" is-function name)) (let ((cruft `(,*interpreter-instance-variable-marker* ,name ,the-instance ,loc))) (if is-function (push cruft **FNENV**) (push cruft **ENV**)))))))) ;;A little trampoline to get a stack vector (DEFUN BIND-ARGS-LIST (BVL &RESTV ARGS) (BIND-ARGS BVL (OR ARGS #()))) (DEFUN BIND-ARGS (BVL ARGS) (WHEN (NULL ARGS) (SETQ ARGS #())) (DO ((ARGI 0) (NARGS (VECTOR-LENGTH ARGS)) (B BVL (CDR B))) (()) (COND ((NULL B) ;ran out of vars (IF (= ARGI NARGS) ;ran out of args, too (RETURN ()) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too many arguments supplied" BVL ARGS))) ((KEYWORD-P (CAR B)) (RETURN (CASEQ (CAR B) ((&OPTIONAL) (BIND-OPTIONAL-ARGS (CDR B) ARGS ARGI)) ((&REST &RESTL &RESTV) (BIND-REST-ARG (CAR B) (CDR B) ARGS ARGI)) ((&AUX) (IF (>= ARGI NARGS) ;used all the args (BIND-AUX-VARS (CDR B)) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too many arguments supplied" BVL ARGS))) (#T (FERROR () "Unrecognized &keyword ~S" (CAR B)))))) ((>= ARGI NARGS) ;used up all the args (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too few arguments supplied" BVL ARGS)) (#T (BIND-ONE-ARG (CAR B) (VREF ARGS ARGI)) (INCREMENT ARGI))))) (DEFUN BIND-OPTIONAL-ARGS (BVL ARGS ARGI) (DO ((B BVL (CDR B)) (NARGS (VECTOR-LENGTH ARGS))) (()) (COND ((NULL B) ;ran out of vars (IF (= ARGI NARGS) ;used up all args, too (RETURN ()) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too many arguments supplied" BVL ARGS))) ((KEYWORD-P (CAR B)) (RETURN (CASEQ (CAR B) ((&REST &RESTL &RESTV) (BIND-REST-ARG (CAR B) (CDR B) ARGS ARGI)) ((&AUX) (IF (>= ARGI NARGS) (BIND-AUX-VARS (CDR B)) (FERROR ':WRONG-NUMBER-ARGUMENTS "~S ~S too many arguments supplied" BVL ARGS))) (#T (FERROR () "Bad or misplaced &keyword ~s" (CAR B)))))) ((>= ARGI NARGS) ;ran out of args (RETURN (BIND-MISSING-OPTIONAL-ARGS B))) ((PAIRP (CAR B)) (CASEQ (LIST-LENGTH (CAR B)) ((1 2) (BIND-ONE-ARG (CAAR B) (VREF ARGS ARGI)) (INCREMENT ARGI)) ((3) (BIND-ONE-ARG (CAAR B) (VREF ARGS ARGI)) (INCREMENT ARGI) (BIND-ONE-ARG (THIRD (CAR B)) #T)) (#T (FERROR () "Bad &OPTIONAL frob too long ~s" (CAR B))))) (#T (BIND-ONE-ARG (CAR B) (VREF ARGS ARGI)) (INCREMENT ARGI))))) (DEFUN BIND-MISSING-OPTIONAL-ARGS (BVL) (DO ((B BVL (CDR B))) ((NULL B)) (LET ((V (CAR B))) (COND ((KEYWORD-P V) (RETURN (CASEQ V ((&REST &RESTL &RESTV) (BIND-REST-ARG V (CDR B) #() 1)) ((&AUX) (BIND-AUX-VARS (CDR B))) (#T (FERROR () "Bad or misplaced &keyword ~s" V))))) ((SYMBOLP V) (BIND-ONE-ARG V ())) ((PAIRP V) (CASEQ (LIST-LENGTH V) ((1) ;Simply optional (BIND-ONE-ARG (CAR V) ())) ((2) ;default supplied (BIND-ONE-ARG (CAR V) (INTERNAL-EVAL (CADR V) ()))) ((3) ;default and supplied-p (BIND-ONE-ARG (CAR V) (INTERNAL-EVAL (CADR V) ())) (BIND-ONE-ARG (CADDR V) ())) (#T (FERROR () "&OPTIONAL list too long ~s" V)))) (#T (FERROR () "Bad LAMBDA list syntax ~s" V)))))) (DEFUN BIND-REST-ARG (REST-TYPE BVL ARGS ARGI) (IF (NULL BVL) (FERROR () "Missing BVL tail after ~s" REST-TYPE) (LET ((NARGS (VECTOR-LENGTH ARGS))) (BIND-ONE-ARG (CAR BVL) (COND ((EQ REST-TYPE '&RESTL) (IF (>= ARGI NARGS) () (DO ((I (1- NARGS) (1- I)) (L () (CONS (VREF ARGS I) L))) ((< I ARGI) L)))) ((>= ARGI NARGS) #()) (#T (LET ((V (MAKE-VECTOR (- NARGS ARGI)))) (DOTIMES (I (- NARGS ARGI)) (VSET V I (VREF ARGS (+ I ARGI)))) V)))) (COND ((NULL (CDR BVL))) ((EQ (CADR BVL) '&AUX) (BIND-AUX-VARS (CDDR BVL))) (#T (FERROR () "Garbage in tail of bvl ~s" BVL)))))) (DEFUN BIND-AUX-VARS (BVL) (MAPC #'(LAMBDA (BV) (COND ((NULL BV)) ((SYMBOLP BV) (BIND-ONE-ARG BV ())) ((ATOM BV) (FERROR () "Bad &AUX frob ~s" BV)) (#T (CASEQ (LIST-LENGTH BV) ((1) (BIND-ONE-ARG (CAR BV) ())) ((2) (BIND-ONE-ARG (CAR BV) (INTERNAL-EVAL (CADR BV) ()))) (#T (FERROR () "Bad &AUX frob too long ~s" BV)))))) BVL)) ;A semi-predicate, returning X if it's a known keyword, & if unknown kywd, ;else () (DEFUN KEYWORD-P (X) (AND (SYMBOLP X) (LET ((PNAME (GET-PNAME X))) (AND (> (STRING-LENGTH PNAME) 0) (EQ (CHAR PNAME 0) ~/&) (IF (MEMQ X '(&OPTIONAL &REST &RESTL &RESTV &FUNCTION &VARIABLE)) X '&))))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; END:  N;;; ZEVALS Special Forms -*-Package:EVAL; Mode:LISP-*- (DECLARE (SPECIAL **ENV** **FNENV** **EXIT** **WIN** **PROG-ENV** *SPECIAL-FORM-INITS* **INITIALIZED** /P T NIL)) (DEF-OPEN-CODED INTERPRETER (X) (GET X 'INTERPRETER)) (DEF-OPEN-CODED SET-INTERPRETER (X FUN) (PUT X 'INTERPRETER FUN)) ;(DEF-OPEN-CODED MACRO-DEFINITION (X) (GET X 'MACRO)) ;(DEF-OPEN-CODED SET-MACRO-DEFINITION (X FUN) (PUT X 'MACRO FUN)) (DEF-OPEN-CODED CLOSUREP (FUN) (AND (PAIRP FUN) (EQ (CAR FUN) '&CLOSURE))) ;;; Special forms (EVAL-WHEN (EVAL COMPILE) (SETQ *SPECIAL-FORM-INITS* '())) (MACRO DEFINE-SPECIAL-FORM (X) (LET ((NAME (CADR X)) (Z (CDDR X))) (LET ((X (SYMBOLCONC NAME '-SPECIAL-FORM-FUNCTION))) (OR (ASSQ NAME *SPECIAL-FORM-INITS*) (PUSH (CONS NAME X) *SPECIAL-FORM-INITS*)) `(DEFUN ,X . ,Z)))) (MACRO THE-SPECIAL-FORM-INITS (()) ;; No MAPC for now. `(DO ((L ',(REVERSE *SPECIAL-FORM-INITS*) (CDR L))) ((NULL L)) (SET-INTERPRETER (CAAR L) (FSYMEVAL (CDAR L))))) (MACRO INTERPRETER-RETURN-POINT (FORM) (LET (((NAME . BODY) (CDR FORM)) (NAMEV (GENTEMP 'NAME)) (VALV (GENTEMP 'VAL))) `(LET (((,NAMEV ,VALV) (*CATCH 'SI:DORETURN ,@BODY))) (IF (EQ ,NAMEV ,NAME) ,VALV (*THROW 'SI:DORETURN `(,,NAMEV ,,VALV)))))) (DEFINE-SPECIAL-FORM MACRO (FORM) (LET ((SYM (CADR FORM))) (SET-MACRO-DEFINITION SYM (MAKE-CLOSURE '**MACRO-ENV** '**MACRO-FNENV** (CDDR FORM) SYM)) (SET-INTERPRETER SYM #'INTERPRET-MACRO-FORM) SYM)) (DEFUN INTERPRET-MACRO-FORM (FORM) (LET ((M (MACRO-DEFINITION (CAR FORM)))) (IF M (INTERNAL-EVAL (FUNCALL M FORM) ()) (CERROR T () ':UNDEFINED-FUNCTION "No macro definition for ~S" (CAR FORM))))) (DEFINE-SPECIAL-FORM DEFUN (FORM) (LET ((SYM (CADR FORM))) (ZFSET SYM (MAKE-CLOSURE '**DEFUN-ENV** '**DEFUN-FNENV** (CDDR FORM) SYM)) SYM)) (DEFINE-SPECIAL-FORM LAMBDA (FORM) (MAKE-CLOSURE **ENV** **FNENV** (CDR FORM) '*CLOSURE*)) ;;; ... and more of the same. (DEFINE-SPECIAL-FORM SETQ (FORM) (DO ((L (CDR FORM) (CDDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CADR L) ())) (INTERPRETER-SET (CAR L) VAL))) (DEFINE-SPECIAL-FORM FSETQ (FORM) (DO ((L (CDR FORM) (CDDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CADR L) ())) (INTERPRETER-FSET (CAR L) VAL))) (DEFINE-SPECIAL-FORM COMMENT (EXP) (CAR EXP)) (DEFINE-SPECIAL-FORM DECLARE (EXP) (CAR EXP)) ;Yeah, I know... (DEFINE-SPECIAL-FORM SPECIAL (EXP) (DOLIST (VAR (CDR EXP)) (DO () ((SYMBOLP VAR)) (SETQ VAR (CERROR #T () ':WRONG-TYPE-ARGUMENT "Can't SPECIALify nonsymbol ~s" VAR))) (PUTPROP VAR #T 'SPECIAL))) (DEFINE-SPECIAL-FORM QUOTE (EXP) (CADR EXP)) (DEFINE-SPECIAL-FORM FUNCTION (EXP) (INTERNAL-EVAL (CADR EXP) T)) (DEFINE-SPECIAL-FORM AND (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) VAL) (SETQ VAL (INTERNAL-EVAL (CAR L) ())) (COND ((NOT VAL) (RETURN ()))))) (DEFINE-SPECIAL-FORM OR (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) ()) (SETQ VAL (INTERNAL-EVAL (CAR L) ())) (COND (VAL (RETURN VAL))))) (DEFINE-SPECIAL-FORM IF (EXP) (LET (((() P C . A) EXP)) (IF (INTERNAL-EVAL P ()) (INTERNAL-EVAL C ()) (EVAL-SEQ A)))) (DEFINE-SPECIAL-FORM COND (EXP) (DO ((L (CDR EXP) (CDR L)) (VAL)) ((NULL L) ()) (SETQ VAL (INTERNAL-EVAL (CAAR L) ())) (COND ((NOT VAL)) ((NULL (CDAR L)) (RETURN VAL)) (#T (RETURN (EVAL-SEQ (CDAR L))))))) (DEFINE-SPECIAL-FORM WHEN (EXP) (WHEN (INTERNAL-EVAL (CADR EXP) ()) (EVAL-SEQ (CDDR EXP)))) (DEFINE-SPECIAL-FORM UNLESS (EXP) (UNLESS (INTERNAL-EVAL (CADR EXP) ()) (EVAL-SEQ (CDDR EXP)))) ;;; RETURN, GO, DO, PROG (DEFINE-SPECIAL-FORM RETURN (EXP) (DOLIST (ENV **PROG-ENV**) (UNLESS (EQ (CAR ENV) 'T) (*THROW 'SI:DORETURN `(,(CAR ENV) ,(INTERNAL-EVAL (CADR EXP) ()))))) (FERROR () "RETURN not inside DO or PROG")) (DEFINE-SPECIAL-FORM RETURN-FROM (EXP) (LET (((RETURN-FROM NAME VAL) EXP)) RETURN-FROM (DOLIST (ENV **PROG-ENV**) (WHEN (EQ NAME (CAR ENV)) (*THROW 'SI:DORETURN `(,NAME ,(INTERNAL-EVAL VAL ()))))) (FERROR () "~S RETURN-FROM name not found" NAME))) (DEFINE-SPECIAL-FORM GO (EXP) (CASEQ (LENGTH EXP) (2 (LET ((TAG (CADR EXP))) (DOLIST (PROG-ENV **PROG-ENV**) (UNLESS (EQ (CAR PROG-ENV) 'T) (LET ((FOUND (MEMQ TAG (CADR PROG-ENV)))) (WHEN FOUND (*THROW 'SI:DOGO `(,(CAR PROG-ENV) ,FOUND)))))) (FERROR () "~S Unseen GO tag" TAG))) (3 (LET (((GO NAME TAG) EXP)) GO (LET ((PROG-ENV (ASSQ NAME **PROG-ENV**))) (IF (NULL PROG-ENV) (FERROR () "~S Unseen PROG name" NAME) (LET ((FOUND (MEMQ TAG (CADR PROG-ENV)))) (IF FOUND (*THROW 'SI:DOGO `(,NAME ,TAG)) (FERROR () "~S Unseen GO tag for name ~S" TAG NAME))))))) (#T (FERROR () "~S Badly-formed GO" EXP)))) (DEFINE-SPECIAL-FORM DO (EXP) (COND ((LISTP (CADR EXP)) (LET (((DO VARS PREDL . BODY) EXP)) DO (INTERPRET-DO () VARS PREDL BODY))) ((SYMBOLP (CADR EXP)) (LET (((DO VAR INIT STEP PRED . BODY) EXP)) DO (INTERPRET-DO () `((,VAR ,INIT ,STEP)) `(,PRED) BODY))) (#T (FERROR () "~S Bad var list in DO" (CADR EXP))))) (DEFINE-SPECIAL-FORM DO-NAMED (EXP) (LET (((DO NAME VARS PREDL . BODY) EXP)) DO (INTERPRET-DO NAME VARS PREDL BODY))) (DEFINE-SPECIAL-FORM PROG (EXP) (LET (NAME ((PROG VARL . BODY) EXP)) PROG (WHEN (AND VARL (SYMBOLP VARL)) ;Named PROG? (SETQ NAME VARL VARL (CAR BODY) BODY (CDR BODY))) (INTERPRET-DO NAME ;Can't (MAPCAR #'(LAMBDA (X) (LIST X)) VARL) yet (DO ((VARL VARL (CDR VARL)) (L)) ((NULL VARL) (NREVERSE L)) (PUSH (LIST (CAR VARL)) L)) () BODY))) (DEFUN INTERPRET-DO (DONAME VARSPECS PREDL BODY) (DO ((SPECS VARSPECS (CDR SPECS)) (ENV **ENV**) (FNENV **FNENV**)) ((NULL SPECS) (LET ((**ENV** ENV) (**FNENV** FNENV) (**PROG-ENV** (CONS `(,DONAME ,BODY) **PROG-ENV**))) (INTERPRET-DOBODY DONAME VARSPECS PREDL BODY))) ---- (LET (((VAR INIT STEP) (CAR SPECS))) STEP (COND ((NULL VAR) (INTERNAL-EVAL INIT ())) ((SYMBOLP VAR) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT ())) ENV)) ((ATOM VAR) (FERROR () "~S Bad variable in DO" VAR)) ((EQ (CAR VAR) '&VARIABLE) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT ())) ENV)) ((EQ (CAR VAR) '&FUNCTION) (PUSH `(,VAR . ,(INTERNAL-EVAL INIT #T)) FNENV)) (#T (FERROR () "~S Bad variable in DO" VAR)))) ---)) (DEFUN INTERPRET-DOBODY (DONAME VARSPECS PREDL BODY) (LET (((RETNAME RETVAL) (*CATCH 'SI:DORETURN (DO ((NOT-1ST () #T)) ((AND PREDL (INTERNAL-EVAL (CAR PREDL) ())) `(,DONAME ,(EVAL-SEQ (CDR PREDL)))) ---- (WHEN (AND NOT-1ST (NULL PREDL)) (RETURN `(,DONAME ()))) (DO ((BOD BODY) (GOFOO)) ((NOT (SETQ GOFOO (*CATCH 'SI:DOGO (DOLIST (ITEM BOD) (UNLESS (ATOM ITEM) (INTERNAL-EVAL ITEM ()))))))) ---- (LET (((NAME GOBOD) GOFOO)) (COND ((NOT (EQ NAME DONAME)) (*THROW 'SI:DOGO GOFOO)) (#T (SETQ BOD GOBOD)))) ---) (STEP-DO-VARSPECS VARSPECS) ---)))) (IF (EQ RETNAME DONAME) RETVAL (*THROW 'SI:DORETURN `(,RETNAME ,RETVAL))))) (DEFUN STEP-DO-VARSPECS (VARSPECS) (DO ((VARS) (VALS) (FNVARS) (FNVALS) (SPECS VARSPECS (CDR SPECS))) ((NULL SPECS) (DO ((VARS VARS (CDR VARS)) (VALS VALS (CDR VALS)) (VAR) (VAL)) ((OR (NULL VARS) (NULL VALS))) (SETQ VAR (CAR VARS) VAL (CAR VALS)) (INTERPRETER-SET (IF (ATOM VAR) VAR (CADR VAR)) VAL)) (DO ((FNVARS FNVARS (CDR FNVARS)) (FNVAR) (FNVALS FNVALS (CDR FNVALS)) (FNVAL)) ((OR (NULL FNVARS) (NULL FNVARS))) (SETQ FNVAR (CAR FNVARS) FNVAL (CAR FNVALS)) (INTERPRETER-FSET FNVAR FNVAL)) #T) ---- (LET (((VAR INIT . STEPP) (CAR SPECS))) INIT (COND (STEPP ;Stepper present (COND ((NULL VAR)) ((AND (PAIRP VAR) (EQ (CAR VAR) '&FUNCTION)) (PUSH VAR FNVARS) (PUSH (INTERNAL-EVAL (CAR STEPP) #T) FNVALS)) (#T (PUSH VAR VARS) (PUSH (INTERNAL-EVAL (CAR STEPP) ()) VALS)))))) ---)) ;;; CATCH, CASEQ (DEFINE-SPECIAL-FORM CATCH (EXP) (*CATCH (INTERNAL-EVAL (CADR EXP) ()) (EVAL-SEQ (CDDR EXP)))) (DEFINE-SPECIAL-FORM *CATCH (EXP) (*CATCH (INTERNAL-EVAL (CADR EXP) ()) (EVAL-SEQ (CDDR EXP)))) (DEFUN THROW (TAG VAL) (*THROW TAG VAL)) (DEFUN *THROW (TAG VAL) (*THROW TAG VAL)) (DEFINE-SPECIAL-FORM CASEQ (EXP) (LET ((KEY (INTERNAL-EVAL (CADR EXP) ()))) (EVAL-CASEQ (TYPE-OF KEY) KEY (CDDR EXP)))) (DEFINE-SPECIAL-FORM TYPECASEQ (EXP) (EVAL-CASEQ 'SYMBOL (TYPE-OF (INTERNAL-EVAL (CADR EXP) ())) (CDDR EXP))) ;;; This definition depends on FIXNUMs being EQ to themselves in real Nil. (DEFUN EVAL-CASEQ (TYPE KEY CLAUSES) (DOLIST (CLAUSE CLAUSES) (WHEN (OR (MEMQ (CAR CLAUSE) '(T #T)) (CASEQ-CASE-MATCH? TYPE KEY (CAR CLAUSE))) (RETURN (EVAL-SEQ (CDR CLAUSE)))))) (DEFUN CASEQ-CASE-MATCH? (TYPE KEY KEY?S) (IF (ATOM KEY?S) (COND ((EQ KEY KEY?S) #T) ((EQ (TYPE-OF KEY?S) TYPE) ()) (#T (FERROR () "~S CASEQ key not of type ~S" KEY?S TYPE))) (DOLIST (K KEY?S) (COND ((EQ KEY K) (RETURN #T)) ((EQ (TYPE-OF K) TYPE) ()) (#T (FERROR () "~S CASEQ key not of type ~S" K TYPE)))))) (DEFINE-SPECIAL-FORM PROGN (EXP) (EVAL-SEQ (CDR EXP))) (DEFINE-SPECIAL-FORM PROG1 (EXP) (LET ((VAL (INTERNAL-EVAL (CADR EXP) ()))) (EVAL-SEQ (CDDR EXP)) VAL)) (DEFINE-SPECIAL-FORM PROG2 (EXP) (INTERNAL-EVAL (CADR EXP) ()) (LET ((VAL (INTERNAL-EVAL (CADDR EXP) ()))) (EVAL-SEQ (CDDDR EXP)) VAL)) (DEFINE-SPECIAL-FORM EVAL-WHEN (EXP) (AND (MEMQ 'EVAL (CADR EXP)) (EVAL-SEQ (CDDR EXP)))) ;;; Macro-like forms (define-special-form within-instance-of-flavor-internal (form) (let (((() arg . body) form)) (let ((*wifi-flavor-name* (car arg))) (declare (special *wifi-flavor-name*)) (bind-instance-variables arg) (eval-seq body)))) (defmacro interpret-progn (&rest foo) `(eval-seq ,@foo)) (defmacro with-interpreter-bindings (vars vals . body) `(let (*random-special*) (declare (special *random-special*)) (mapc #'(lambda (var val) (bind-one-arg var val)) ,vars ,vals) ,@body)) (defmacro with-interpreter-binding1 ((var val) . body) `(let (*random-special*) (declare (special *random-special*)) (bind-one-arg ,var ,val) ,@body)) (define-special-form dotimes (form) (let (((spec . body) (cdr form)) var) (cond ((atom spec) (setq spec (internal-eval spec ())) (do i 1 (1+ i) (> i spec) (interpret-progn body))) ((null (progn (desetq (var spec) spec) (setq spec (internal-eval spec ())) var)) (do i 1 (1+ i) (> i spec) (interpret-progn body))) ('T (with-interpreter-binding1 (var 0) (interpreter-return-point () (do ((i 0 (1+ i)) (**prog-env** (cons `(() ,body) **prog-env**))) ((>= i spec)) (interpreter-set var i) (interpret-progn body)))))))) (define-special-form dolist (form) (let ((((var list idx) . body) (cdr form)) varl vall) (setq list (internal-eval list ()) varl (list var) vall '(())) (when idx (push idx varl) (push '0 vall)) (with-interpreter-bindings varl vall (interpreter-return-point () (do ((l list (cdr l)) (i 0 (1+ i)) (**prog-env** (cons `(() ,body) **prog-env**))) ((null l)) (interpreter-set var (car l)) (when idx (interpreter-set idx i)) (interpret-progn body)))))) (define-special-form dovector (form) (let ((((var vec idx) . body) (cdr form))) (setq vec (internal-eval vec ())) (with-interpreter-binding1 (var ()) (when idx (bind-one-arg idx 0)) (interpreter-return-point () (do ((i 0 (1+ i)) (n (vector-length vec)) (**prog-env** (cons `(() ,body) **prog-env**))) ((>= i n)) (when idx (interpreter-set idx i)) (interpreter-set var (vref vec i)) (interpret-progn body)))))) (define-special-form let (form) (let-interpreter (cadr form) (cddr form))) (defun let-interpreter (bvl forms) (do ((bvl bvl (cdr bvl)) (varl) (vall) (bvf)) ((atom bvl) (when bvl (error '|Nonnull bvl terminator - LET| bvl)) (with-interpreter-bindings (setq varl (nreverse varl)) (setq vall (nreverse vall)) (interpret-progn forms))) (cond ((null (setq bvf (car bvl)))) ((symbolp bvf) (push bvf varl) (push () vall)) ((not (atom bvf)) (desetq (varl . vall) (let-destructure (car bvf) (internal-eval (cadr bvf) ()) varl vall))) ((error '|Unrecognized bvf - LET| bvf))))) (define-special-form let* (form) (let*-interpreter (cadr form) (cddr form))) (defun let*-interpreter (bvl forms) (cond ((null bvl) (interpret-progn forms)) ((atom bvl) (error '|Nonnull bvl terminator - LET*-INTERPRETER| bvl)) ('T (let (((varl . vall) (let-destructure (caar bvl) (internal-eval (cadar bvl) ()) () ()))) (with-interpreter-bindings varl vall (let*-interpreter (cdr bvl) forms)))))) (define-special-form desetq (form) (desetq-interpreter (cadr form) (caddr form))) (defun desetq-interpreter (pat val) (setq pat (let-destructure pat (internal-eval val ()) () ())) (setq val (nreverse (cdr pat)) pat (nreverse (car pat))) (mapc #'interpreter-set pat val)) (defun let-destructure (pat val varl vall) (cond ((null pat)) ((symbolp pat) (push pat varl) (push val vall)) ((not (atom pat)) (do ((pat pat (cdr pat)) (val val (cdr val))) ((or (atom pat) (and val (atom val))) ;CARCDR () ad lib. (cond ((null pat)) ((atom pat) (push pat varl) (push val vall)) ((atom val) (error '|Destructuring nonatom across atom - LET-DESTRUCTURE| (list pat val) 'fail-act)) ('T (error '|Huh? - LET-DESTRUCTURE| (list pat val))))) (desetq (varl . vall) (let-destructure (car pat) (car val) varl vall)))) ((vectorp pat) (cond ((vectorp val) (do ((i 0 (1+ i)) (nvars (vector-length pat)) (nvals (vector-length val))) ((>= i nvars)) (desetq (varl . vall) (let-destructure (vref pat i) (and (< i nvals) (vref val i)) varl vall)))) ('T (error '|Destructuring vector across non-vector - LET-DESTRUCTURE| (list pat val) 'fail-act)))) ('T (error '|Can't destructure pat - LET-DESTRUCTURE| pat 'fail-act))) (cons varl vall)) ;;; Initialization and top-level (DEFUN INIT-ZEVAL () (DECLARE (SPECIAL PACKAGE)) (SETQ **ENV** '**TOP-LEVEL-ENV**) (SETQ **FNENV** '**TOP-LEVEL-FNENV**) (SETQ /P (SETQ **EXIT** '**EXIT**)) (SETQ **WIN** #T) ;(FBOUNDP 'SI:APPLY-SUBR) #+NIL (progn (or (fboundp 'eval) (FSETQ EVAL #'ZEVAL)) (or (fboundp 'apply) (fsetq APPLY #'ZAPPLY)) (or (fboundp 'READ) (fsetq READ #'ZREAD)) (or (fboundp 'PRIN1) (fsetq PRIN1 #'ZPRIN1)) (or (fboundp 'PRINT) (fsetq PRINT #'ZPRINT)) (or (fboundp 'TERPRI) (fsetq TERPRI #'ZTERPRI)) (or (fboundp 'NREVERSE) (fsetq NREVERSE #'ZREAD-NREVERSE))) #+NIL (progn (SETQ T (NOT ())) (SET (SI:RINTERN "NIL" 3 PACKAGE) (NOT 'T))) (THE-SPECIAL-FORM-INITS) (SETQ **INITIALIZED** 'INITIALIZED)) #+NIL (FSETQ APPLY #'ZAPPLY) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END: p; CHURCH NUMERALS -*-LISP-*- ; The following is a transcription into SCHEME of some formulas from ; Alonzo Church's "The Calculi of Lambda-Conversion," published in ; 1941 by Princeton University Press. (DEFUN I (X) X) ;Identity. (DEFUN C1 ((&FUNCTION F)) (LAMBDA (A) (F A))) ;The number 1. (DEFUN C2 ((&FUNCTION F)) (LAMBDA (A) (F (F A)))) ;The number 2. (DEFUN C3 ((&FUNCTION F)) (LAMBDA (A) (F (F (F A))))) ;The number 3. (DEFUN C4 ((&FUNCTION F)) (LAMBDA (A) (F (F (F (F A)))))) ;The number 4. (DEFUN S ((&FUNCTION N)) ;Successor. (LAMBDA ((&FUNCTION F)) (LAMBDA (V) (F ((N #'F) V))))) (DEFUN C+ ((&FUNCTION M) (&FUNCTION N)) ;Addition (LAMBDA (F) (LAMBDA (V) ((N F) ((M F) V))))) (DEFUN C* ((&FUNCTION M) (&FUNCTION N)) ;Multiplication (LAMBDA (F) (M (LAMBDA (A) ((N F) A))))) (DEFUN C^ (M (&FUNCTION N)) ;Exponentiation (N M)) (DEFUN PAIR (M N) (LAMBDA ((&FUNCTION Q)) (Q M N))) (DEFUN P1 ((&FUNCTION Z)) (Z (LAMBDA (M N) M))) (DEFUN P2 ((&FUNCTION Z)) (Z (LAMBDA (M N) N))) (DEFUN TRIPLE (L M N) (LAMBDA ((&FUNCTION Q)) (Q L M N))) (DEFUN T1 ((&FUNCTION Z)) (Z (LAMBDA (L M N) L))) (DEFUN T2 ((&FUNCTION Z)) (Z (LAMBDA (L M N) M))) (DEFUN T3 ((&FUNCTION Z)) (Z (LAMBDA (L M N) N))) (DEFUN P ((&FUNCTION A)) ;Predecessor. (T3 ((A (LAMBDA (B) (TRIPLE (S (T1 B)) (T1 B) (T2 B)))) (TRIPLE #'C1 #'C1 #'C1)))) (DEFUN C- (M (&FUNCTION N)) ((N #'P) M)) (DEFUN CMIN (A B) (C- (S B) (C- (S B) A))) (DEFUN CMAX (A B) (C- (C+ A B) (CMIN A B))) (DEFUN PAR ((&FUNCTION A)) ;Parity (EVENP). ((A (LAMBDA (B) (C- #'C3 B))) #'C2)) (DEFUN H ((&FUNCTION A)) ;Ceiling A / 2. (P (P1 ((A (LAMBDA (B) (PAIR (P (C+ (P1 B) (P2 B))) (C- #'C3 (P2 B))))) (PAIR #'C1 #'C2))))) ; The numbers 1 and 2 represent false and true, respectively. (DEFUN C> (A B) (CMIN #'C2 (C- (S A) B)))) ;Greater than. (DEFUN C= (A B) (C- #'C4 (C+ (C> A B) (C> B A)))) ;Equality. ; Note that primitive recursion and mu-recursion are also definable, ; thus we could (theoretically) write a "universal calculator." ; Interface to NIL. Unfortunately TYPEP is kind of missing from all this. (DEFUN CVAL ((&FUNCTION N)) ((N #'1+) 0)) ;Numeric value. (DEFUN CIFY (Z) (IF (> Z 1) (P (CIFY (1- Z))) #'C1)) ;Church numeral. (DEFUN CBVAL (B) (= (CVAL B) 2)) ;Boolean value. (DEFUN CBIFY (Z) (IF Z #'C2 #'C1)) ;Convert to Church Boolean. j;-*-LISP-*- (HERALD CODEWALK) #-NIL (declare (*lexpr cw:find-var)) ;; A the various CONTOUR structures are structures which keeps track of what ;; variables have been bound and the scoping thereof. (defvst global-contour bindings user-slot contained-contours) (defvst lambda-contour bindings user-slot containing-contour contained-contours) (defprop lambda-contour (containing-contour) suppressed-component-names) (defvst prog-contour bindings prog-tags user-slot containing-contour contained-contours) (defprop prog-contour (containing-contour) suppressed-component-names) (defvst closure-contour bindings ;Variable bindings captured capture-all-specials ;(), (:VALUE), (:FUNCTION) or capture-all-lexicals ;(:VALUE :FUNCTION) user-slot containing-contour contained-contours) (defprop closure-contour (containing-contour) suppressed-component-names) ;; A VAR-BINDING structure keeps the information about an individual binding of ;; a variable. (defvst var-binding name ;Variable name cell-type ;Function/Value scoping ;Special/Lexical linkable ;Simple/Shared Not valid in pass 1 contour-bound-in ;Contour it is bound in (used 0) ;# times ref'd Not valid in pass 1 set ;T if SETQ'd Not valid in pass 1 closures-used-in) ;List of closures Not valid in pass 1 (defprop var-binding (closures-used-in contour-bound-in) suppressed-component-names) (defvar cw:atom-fun () "A function which is FUNCALLed on all atoms encountered to be EVALed") (defvar cw:macro-copy () "If true, copy the top level cons of a macro form before passing to MACROEXPAND-1, to avoid clobbering the original structure.") (defvar cw:tag () "The tag to get study functions from function's PLISTs") (defvar cw:binding-context () "The current binding-context structure, with information regarding what variables have been bound how. See the LAMBDA-CONTOUR structure.") (defvar cw:global-binding-context (cons-a-global-contour) "The context which all free variable-bindings appear") (defvar cw:two-pass-mode () "If true, we are in two-pass mode. This means lambda bodies will be examined once to fill in the lambda-contour information, and once to process the structure based on that information.") (defvar cw:pass () "When in two-pass mode, this has either :PASS1 or :PASS2 to indicate which phase of processing is being performed.") (defvar cw:all-fun-fun () "If non-null, a function to be called on all function calls instead of the usual actions.") (defvar cw:all-macros-fun () "If non-null, a function to be called on all macro calls instead of the usual actions.") (defvar cw:recurse-lambda-apply-hook () "A function to call on lambda applications encountered instead of the usual actions") (defvar cw:recurse-lambda-hook () "A function to call on LAMBDA's encountered instead of the usual actions") (defvar cw:specials () "A list of variables assumed to be declared SPECIAL outside the scope CODE-WALK was called on") (defvar cw:recurse-bind-hook () "If non-null, a function to be called from CW:RECURSE to bind special variables, etc, and call CW:RECURSE-1. If null, CW:RECURSE calls CW:RECURSE-1 directly.") (defvar cw:for-value 'T "If true, the current form is in a position to be evaluated for value rather than for effect only.") (defmacro cw:call (&rest argl) `(funcall ,. argl)) (defun code-walk (form &restl options) "Walk over code, performing analysis or performing rewrites." (setq options (cons 'options options)) (let ((cw:macro-copy (get options ':MACRO-COPY)) (cw:binding-context () ) (cw:tag (get options ':TAG)) (cw:global-binding-context (or (get options ':GLOBAL-BINDING-CONTEXT) (cons-a-lambda-contour))) (cw:specials (get options ':GLOBAL-SPECIALS)) (cw:two-pass-mode (get options ':TWO-PASS)) (cw:recurse-lambda-apply-hook (get options ':LAMBDA-APPLICATION-HOOK)) (cw:recurse-lambda-hook (get options ':LAMBDA-HOOK)) (cw:atom-fun (get options ':ATOM-FUN)) (cw:recurse-bind-hook (get options ':RECURSE-BIND-HOOK)) (cw:all-macros-fun (get options ':ALL-MACROS-FUN)) (cw:all-fun-fun (get options ':ALL-FUN-FUN)) (cw:for-value 'T)) (send cw:global-binding-context ':ADD-BINDINGS (cw:special-variable-bindings cw:specials cw:global-binding-context)) (setq cw:binding-context cw:global-binding-context) (cw:recurse form))) (defun cw:recurse-1 (form) "Inner recursive function for CODE-WALK. Only called from inside CW:RECURSE or from inside the user hook CW:RECURSE-BIND-HOOK called from CW:RECURSE" (if form (if (atom form) (progn (send cw:binding-context ':note-var-seen form ':VALUE) (if cw:atom-fun (cw:call cw:atom-fun form) form)) (let (( (fun . argl) form)) (cond ((symbolp fun) (cw:recurse-fun form)) ((atom fun) (cw:recurse-funny-fun form)) (t (cw:recurse-combination form))))))) (defun cw:recurse (form) "The basic recursive function for walking code recursively, for use within CODE-WALK." (if cw:recurse-bind-hook (cw:call cw:recurse-bind-hook form) (cw:recurse-1 form))) (defun cw:recurse-fun (form) "Perform code-walk recursion on a function call" (let (( (fun . argl) form)) (send cw:binding-context ':NOTE-VAR-SEEN fun ':FUNCTION) (cond ((eq fun 'LAMBDA) (cw:recurse-LAMBDA form)) (T (do ((hackers (and cw:tag (get fun cw:tag)) (cdr hackers)) (new-form)) ((null hackers) (if (setq hackers (get fun 'cw:recurse)) ;Special form? (cw:call hackers form) (if (macrop fun) (if cw:all-macros-fun (cw:call cw:all-macros-fun (if cw:macro-copy `(,fun ,. argl) form)) (cw:recurse (macroexpand-1 (if cw:macro-copy `(,fun ,. argl) form)))) (if cw:all-fun-fun (cw:call cw:all-fun-fun form) `(,fun ,.(mapcar #'cw:recurse argl)))))) (setq new-form (cw:call (car hackers) form)) (if (not (eq new-form form)) (return new-form))))))) (defun cw:recurse-combination (form) "Recurse code-walking on a LAMBDA (or MACRO, etc.) combination" (let (( (fun . argl) form)) (if (atom fun) (cw:recurse-1 form) ; Just in case check... (do ((fun fun (macroexpand-1 fun)) (ofun fun fun) (ofuncar (car fun) (car fun)) (ofuncdr (cdr fun) (cdr fun))) ((atom fun) (cw:recurse-1 `(,fun ,. argl))) (let (( (type . body) fun)) (cond ((eq type 'LAMBDA) (return (cw:recurse-LAMBDA-call form))) ((eq type 'MACRO) (return (cw:recurse (cw:recurse-MACRO form)))) ((eq type 'SUBST) (cw:recurse (return (cw:recurse-SUBST form)))) ((and (symbolp type) (get type 'cw:recurse-combination)) (return (cw:call (get type 'cw:recurse-combination) form))) ((and (eq fun ofun) (eq ofuncar (car fun)) (eq ofuncdr (cdr fun))) (ferror 'CW:BAD-SYNTAX "A computed function, ~S, was encountered by CODE-WALK" fun)))))))) (defun cw:recurse-MACRO (form) (let (( ( ( () . body) . ()) form)) (funcall `(LAMBDA ,.body) form))) (defun cw:recurse-LAMBDA-CALL (form) "Recurse code-walking on a LAMBDA application. First recurse on the supplied arguments, then analyze the LAMBDA form." (let* (( ( fun . argl) form) (argl (mapcar #'cw:recurse argl))) (if cw:recurse-lambda-apply-hook (cw:call cw:recurse-lambda-apply-hook form) `(,(cw:recurse-lambda fun) ,. argl)))) (defun cw:recurse-LAMBDA (fun) "Recurse code-walking on a LAMBDA form. First handle the bindings, then recurse on the body." (let* (( ( () lvars . body) fun) (cw:binding-context (cw:new-lambda-bindings lvars))) (if cw:recurse-lambda-hook (cw:call cw:recurse-lambda-hook fun) `(LAMBDA ,lvars ,. (mapcar #'cw:recurse body))))) (defun cw:new-lambda-bindings (lvars) "Create a lambda-contour structure describing the bindings from a general LAMBDA variable list." (do ((lvars lvars (cdr lvars)) (cell ':VALUE) (type) (close-class ':SHARED) (mode ':REQUIRED) (varstructs) (new-contour (cons-a-lambda-contour CONTAINING-CONTOUR cw:binding-context))) ((null lvars) (setf (lambda-contour-bindings new-contour) varstructs) (send cw:binding-context ':add-subcontour new-contour) new-contour) (cond ((memq (car lvars) '(&REST &RESTL &RESTV)) (setq mode ':REST)) ((eq (car lvars) '&OPTIONAL) (setq mode ':OPTIONAL)) ((eq (car lvars) '&FUNCTION) (setq cell ':FUNCTION)) ((eq (car lvars) '&VALUE) (setq cell ':VALUE)) ((eq (car lvars) '&SPECIAL) (setq type ':SPECIAL)) ((eq (car lvars) '&LOCAL) (setq type ':LOCAL)) ((eq (car lvars) '&SIMPLE) (setq close-class ':SIMPLE)) ((eq (car lvars) '&SHARED) (setq close-class ':SHARED)) (T (caseq mode ((:REQUIRED :REST) (setq varstructs (nconc (cw:new-binding (car lvars) cell type close-class new-contour) varstructs))) (:OPTIONAL (if (atom (car lvars)) (setq varstructs (nconc (cw:new-binding (car lvars) cell type close-class new-contour) varstructs)) (let (( (vars default present-p) (car lvars))) (setq varstructs (nconc (cw:new-binding vars cell type close-class new-contour) varstructs)) (if default (cw:recurse default)) (if present-p (setq varstructs (nconc (cw:new-binding present-p cell type close-class new-contour) varstructs))))))))))) (defun cw:new-binding (spec cell type close-class contour) "Build a list of variable-bindings from a destructuring-pattern" (if (null spec) () (if (not (atom spec)) (nconc (cw:new-binding (car spec) cell type close-class contour) (cw:new-binding (cdr spec) cell type close-class contour)) (if (null type) (let ((binding (send contour ':FIND-VAR spec cell))) (if binding (setq type (var-binding-scoping binding))))) (ncons (cons-a-var-binding NAME spec CELL-TYPE cell SCOPING type LINKABLE close-class CONTOUR-BOUND-IN contour))))) (defmethod* (:FIND-VAR lambda-contour-class) (contour name &optional (cell-type ':VALUE)) "Find a variable binding structure from a LAMBDA-contour" (or (cw:find-var-in-bindings name cell-type (lambda-contour-bindings contour)) (if (lambda-contour-containing-contour contour) (send (lambda-contour-containing-contour contour) ':FIND-VAR name cell-type)))) (defmethod* (:FIND-VAR prog-contour-class) (contour name &optional (cell-type ':VALUE)) "Find a variable binding structure from a PROG-contour" (or (cw:find-var-in-bindings name cell-type (prog-contour-bindings contour)) (if (prog-contour-containing-contour contour) (send (prog-contour-containing-contour contour) ':FIND-VAR name cell-type)))) (defmethod* (:FIND-VAR global-contour-class) (contour name &optional (cell-type ':VALUE)) "Find a variable binding structure from a GLOBAL-contour" (cw:find-var-in-bindings name cell-type (global-contour-bindings contour))) (defmethod* (:FIND-VAR closure-contour-class) (contour name &optional (cell-type ':VALUE)) "Find a variable binding structure from a CLOSURE-contour" (if (closure-contour-containing-contour) ;Should always be true! (send (closure-contour-containing-contour contour) ':FIND-VAR name cell-type))) (defun cw:find-var-in-bindings (name cell-type bindings) "Given a variable-name, the cell-type, and a list of bindings, return the binding corresponding, or () if none." (do ((vars bindings (cdr vars))) ((null vars)) (if (and (eq name (var-binding-name (car vars))) (eq cell-type (var-binding-cell-type (car vars)))) (return (car vars))))) (defmethod* (:ADD-GLOBAL global-contour-class) (contour name &optional (cell-type ':VALUE) &aux temp) (push (setq temp (cons-a-var-binding NAME name CELL-TYPE cell-type SCOPING ':SPECIAL LINKABLE ':SHARED CONTOUR-BOUND-IN contour)) (global-contour-bindings contour)) temp) (defmethod* (:ADD-GLOBAL LAMBDA-contour-class) (contour name &optional (cell-type ':VALUE)) (send (lambda-contour-containing-contour contour) ':ADD-GLOBAL name cell-type)) (defmethod* (:ADD-GLOBAL CLOSURE-contour-class) (contour name &optional (cell-type ':VALUE) &aux temp) (prog1 (setq temp (send (CLOSURE-contour-containing-contour contour) ':ADD-GLOBAL name cell-type)) (if (memq cell-type (closure-contour-capture-all-specials contour)) (push temp (closure-contour-bindings contour))))) (defmethod* (:ADD-GLOBAL PROG-contour-class) (contour name &optional (cell-type ':VALUE)) (send (PROG-contour-containing-contour contour) ':ADD-GLOBAL name cell-type)) (defmethod* (:NOTE-VAR-SEEN lambda-contour-class) (contour name &optional (cell-type ':VALUE)) "Note that a variable has been referenced in a LAMBDA-contour" (let ((binding (cw:find-var-in-bindings name cell-type (lambda-contour-bindings contour)))) (if (null binding) (if (lambda-contour-containing-contour contour) (send (lambda-contour-containing-contour contour) ':NOTE-VAR-SEEN name cell-type)) (cw:binding-seen binding)))) (defmethod* (:NOTE-VAR-SEEN global-contour-class) (contour name &optional (cell-type ':VALUE)) "Note that a variable has been referenced in a LAMBDA-contour" (cw:binding-seen (cw:find-var name cell-type contour))) (defmethod* (:NOTE-VAR-SEEN PROG-contour-class) (contour name &optional (cell-type ':VALUE)) "Note that a variable has been referenced in a PROG-contour" (let ((binding (cw:find-var-in-bindings name cell-type (prog-contour-bindings contour)))) (if (null binding) (if (prog-contour-containing-contour contour) (send (prog-contour-containing-contour contour) ':NOTE-VAR-SEEN name cell-type)) (cw:binding-seen binding)))) (defmethod* (:NOTE-VAR-SEEN closure-contour-class) (contour name &optional (cell-type ':VALUE)) "Note that a variable has been referenced in a CLOSURE-contour" (let ((binding (cw:find-var-in-bindings name cell-type (closure-contour-bindings contour)))) (if (null binding) ;We known to this closure yet? (progn (setq binding (cw:find-var name cell-type contour)) ;Find it (let ((scoping (var-binding-scoping binding))) ;and add if apropriate (if (or (and (eq scoping ':SPECIAL) (memq cell-type (closure-contour-capture-all-specials contour))) (and (eq scoping ':LEXICAL) (memq cell-type (closure-contour-capture-all-lexicals contour)))) (push binding (closure-contour-bindings contour)))))) (push contour (var-binding-closures-used-in binding)) (send (closure-contour-containing-contour contour) ':NOTE-VAR-SEEN name cell-type))) (defun cw:binding-seen (binding) (setf (var-binding-used binding) (1+ (var-binding-used binding)))) (defun cw:var-set (name cell-type &optional (contour cw:binding-context)) (let ((binding (cw:find-var name cell-type contour))) (setf (var-binding-set binding) 'T) (var-binding-name binding))) (defun cw:find-var (name cell-type &optional (contour cw:binding-context)) (let ((binding (send contour ':FIND-VAR name cell-type))) (if binding binding (send contour ':ADD-GLOBAL name cell-type)))) (defun cw:special-variable-bindings (specials global) (mapc #'(lambda (spec) (if (symbolp spec) (setq spec `(,spec :VALUE :SHARED))) (let (( (name cell-type linkable) spec)) (cons-a-var-binding NAME name CELL-TYPE (or cell-type ':VALUE) SCOPING ':SPECIAL LINKABLE (or linkable ':SHARED) CONTOUR-BOUND-IN global))) specials)) (defmethod* (:GET-BINDINGS GLOBAL-CONTOUR-CLASS) (self) (global-contour-bindings self)) (defmethod* (:GET-BINDINGS LAMBDA-CONTOUR-CLASS) (self) (LAMBDA-contour-bindings self)) (defmethod* (:GET-BINDINGS PROG-CONTOUR-CLASS) (self) (PROG-contour-bindings self)) (defmethod* (:GET-BINDINGS CLOSURE-CONTOUR-CLASS) (self) self ()) (defmethod* (:ADD-BINDINGS GLOBAL-CONTOUR-CLASS) (self bindings) (setf (global-contour-bindings self) (append bindings (global-contour-bindings self)))) (defmethod* (:ADD-BINDINGS LAMBDA-CONTOUR-CLASS) (self bindings) (setf (lambda-contour-bindings self) (append bindings (lambda-contour-bindings self)))) (defmethod* (:ADD-BINDINGS PROG-CONTOUR-CLASS) (self bindings) (setf (prog-contour-bindings self) (append bindings (prog-contour-bindings self)))) ;; This should check for capturing all lexicals or specials, and add apropriate ;; ones to it's list. (defmethod* (:ADD-BINDINGS CLOSURE-CONTOUR-CLASS) (self bindings) (send (closure-contour-containing-contour self) ':ADD-BINDINGS bindings)) (defmethod* (:ADD-SUBCONTOUR GLOBAL-CONTOUR-CLASS) (self subcontour) (push subcontour (global-contour-contained-contours self))) (defmethod* (:ADD-SUBCONTOUR LAMBDA-CONTOUR-CLASS) (self subcontour) (push subcontour (lambda-contour-contained-contours self))) (defmethod* (:ADD-SUBCONTOUR PROG-CONTOUR-CLASS) (self subcontour) (push subcontour (prog-contour-contained-contours self))) (defmethod* (:ADD-SUBCONTOUR CLOSURE-CONTOUR-CLASS) (self subcontour) (push subcontour (closure-contour-contained-contours self))) (defun CW:RECURSE-SETQ (form) "Recurse for SETQ-like functions" (do ((argl (cdr form) (cddr argl)) (retform)) ((null argl) `(,(car form) ,.(nreverse retform))) (push (cw:var-set (car argl) ':value) retform) (push (cw:recurse (cadr argl)) retform))) (mapc #'(lambda (symbol) (putprop symbol #'CW:RECURSE-SETQ 'CW:RECURSE)) '(SETQ PSETQ)) (defun cw:recurse-comment (form) "Recurse not at all, as in for a COMMENT form" form) (mapc #'(lambda (symbol) (putprop symbol #'CW:RECURSE-COMMENT 'CW:RECURSE)) '(comment @define special unspecial trace fasload quote fixnum flonum untrace)) (defun (DECLARE CW:RECURSE) ((fun . argl) &aux temp) `(,fun ,.(mapcar #'(lambda (declare) (if (atom declare) (cw:warn declare) (if (setq temp (get (car declare) 'cw:declare-hacker)) (funcall temp declare) declare))) argl))) (defun (SPECIAL CW:DECLARE-HACKER) (form) (mapc #'(lambda (binding) (if binding (setf (var-binding-scoping binding) (if (eq (car form) 'SPECIAL) ':SPECIAL ':LOCAL)))) (mapcar #'(lambda (symbol) (cw:find-var symbol ':VALUE)) (cdr form))) form) DSK: NILSRC; CODEWA > 01258,LISP (defvst global-contour50 (defvst lambda-contour21 (defvst prog-contour11 (defvst closure-contour16 (defvst var-binding32 (defvar cw:atom-fun 160 (defvar cw:macro-copy 261 (defvar cw:tag 414 (defvar cw:binding-context 506 (defvar cw:global-binding-context 689 (defvar cw:two-pass-mode 798 (defvar cw:pass 013 (defvar cw:all-fun-fun 162 (defvar cw:all-macros-fun 289 (defvar cw:recurse-lambda-apply-hook 424 (defvar cw:specials 539 (defvar cw:recurse-bind-hook 673 (defvar cw:for-value 865 (defmacro cw:call 995 (defun code-walk 052 (defun cw:recurse-1 983 (defun cw:recurse 423 (defun cw:recurse-fun 648 (defun cw:recurse-combination 401 (defun cw:recurse-LAMBDA 317 (defun cw:new-lambda-bindings 784 (defmethod* (:FIND-VAR lambda-contour-class)248 (defmethod* (:FIND-VAR prog-contour-class)644 (defmethod* (:FIND-VAR global-contour-class)034 (defmethod* (:FIND-VAR closure-contour-class)274 (defun cw:find-var-in-bindings 586 (defmethod* (:NOTE-VAR-SEEN lambda-contour-class)977 (defmethod* (:NOTE-VAR-SEEN PROG-contour-class)0469 (defmethod* (:NOTE-VAR-SEEN closure-contour-class)0956 (defun cw:find-var 1864  ;-*-LISP-*- ;CONSers for EXTENDs should get class from value cell CLASS:FOO-CLASS-nnn ; where nnn is the version # of the class (omitted if () ) ;Files using an extend should do ;(CLASS-VERSION-CHECK ',name ,version ,uses) ;where USES is a list of any of: SEND, STRUCT-REFERENCE, STRUCT-SET, CREATE, ; DEFMETHOD (HERALD CLASS) (eval-when (compile eval) (or (get 'DEFSETF 'VERSION) (load '((LISP) DEFSETF)))) #+PDP10 (defsetf *:XREF ((() h n) val) () `(*:XSET ,h ,n ,val)) (defvar si:initial-method-table-size 39. "Must be a prime. The size of a newly created method-table") ;;; Temporary way of defining class slots. Will go into database (defmacro (define-initial-structure DEFMACRO-FOR-COMPILING ()) (name &rest vars &aux (idx 0) (lvar (gensym))) `(progn 'compile ,.(mapcar #'(lambda (spec) (let (( (var documentation) spec)) (prog1 `(defmacro ,(symbolconc name '- var) (,lvar) ,documentation `(*:xref ,,lvar ,',idx)) (setq idx (1+ idx))))) vars) (defvar ,(symbolconc name '-size) ,(length vars)))) (define-initial-structure CLASS (NAME "The name of this class. This is the name printed by print, the name by which the class is usually refered, and is usually the same as the canonical TYPE of the class.") (TYPES "A list of type names this class describes. The first type is the canonical TYPE of the class, and is returned by TYPE-OF. Two-argument TYPEP does a MEMQ down this list, except if the last CDR is non-null, it is a symbol to FUNCALL on the two arguments to the TYPEP.") (SUPERIORS "A list of classes from which this class inherits") (CALL-METHOD "Minisubr to be invoked to handle FUNCALLing this closure") (SEND-METHOD "Minisubr to be invoked to handle delivering a message") (FIND-METHOD-METHOD "Minisubr to fnd the method to handle a message") (METHOD-NAME-TABLE "Hash table of messages used by default SEND-METHOD") (VARIABLE-MAP-TABLE "Parallel table to METHOD-NAME-TABLE of instance-variable maps") (METHOD-FUN-TABLE "Parallel table to METHOD-NAME-TABLE of method functions") (LAST-UPDATE-TIME "Update sequence number of last consistancy check of this class. If this does not equal SI:CLASS-UPDATE-TIME, the class should be sent an UPDATE-SELF message, which will determine if anything has changed, and if so, will update itself. Then this slot will be set to the value of SI:CLASS-UPDATE-TIME on entry. This is checked by the FIND-METHOD-METHOD and CALL-METHOD, but NOT by the SEND-METHOD") (ALIST "An ALIST of other quantities to be associated with a class. System defined tags include :VERSION -- a version number for this class, incremented when making incompatible changes. :DOCUMENTATION -- Description of the purpose and function of this class :SOURCE-FILE -- The file in which the class was defined.")) (defun class-version-check (name version uses) "Check for class consistancy on loading" (mapc #'(lambda (use) (PUSH `(,use ,version ,(current-loading-filename)) (get name 'CLASS:USES))) uses) (let ((class-val-symbol (class-val-symbol name version)) (current-class (get name ':CLASS))) (if (boundp class-val-symbol) (if (not (eq current-class (symeval class-val-symbol))) (cerror t () ':CLASS-VERSION-MISMATCH "The file ~A references version ~S of the class ~S,~%~ but version ~S is current." (current-loading-filename) version name (if current-class (cdr (assq ':VERSION (cls:class-alist current-class))) '|[NONE]|)) (cerror t () ':CLASS-NOT-DEFINED "The class ~S ~:[[Version ~S]~;~*~] is not defined on loading~ file ~A." name version version (current-loading-file))) (create-temporary-class name version)))) (putprop ':NORMAL vm:normal-call-interpreter 'SI:CALL-INTERPRETER) (putprop ':NORMAL vm:normal-SEND-interpreter 'SI:SEND-INTERPRETER) (putprop ':ERROR vm:error-CALL-interpreter 'SI:CALL-INTERPRETER) (defun SI:CREATE-CLASS (name types superiors call-type send-type alist version &optional temp-flag) "Low-level class creator, with error checking and initialization" (let* ((class (if temp-flag (*:extend (get 'class ':CLASS) class-size) (get-specific-class-version name version))) (current-class (get name ':class)) (current-version (and current-class (cdr (assq ':version (:class-alist current-class)))))) (let ((sup-classes)) (dolist (sup superiors) (typecaseq sup (CLASS (push sup sup-classes)) (SYMBOL (push (get sup ':CLASS) sup-classes)) (PAIR (push (get-specific-class-version (car sup) (cdr sup)) sup-classes)))) (setf (class-superiors class) (nreverse sup-classes))) (if (not (cdr (assq ':temporary (:class-alist class)))) (cerror t () ':CLASS-REDEFINIITON "The class ~S is being redefined" class)) (check-argument call-type ':call-interpreter) (check-argument send-type ':send-interpreter) (setf (class-name class) name (class-types class) types (class-alist class) `((:VERSION ,.version) (:SEND-INTERPRETER ,. send-type) (:CALL-INTERPRETER ,. call-type) ,. alist) (class-method-name-table class) (make-vector SI:INITIAL-METHOD-TABLE-SIZE) (class-method-fun-table class) (make-vector SI:INITIAL-METHOD-TABLE-SIZE) (class-variable-map-table class) (make-vector SI:INITIAL-METHOD-TABLE-SIZE) (class-call-method class) (get call-type 'SI:CALL-INTERPRETER) (class-send-method class) (get send-type 'SI:SEND-INTERPRETER)) (unless temp-flag (setf (class-alist class) (remassq ':temporary (class-alist class)))) class)) (defun get-specific-class-version (name version) "Get a specific version of a class. If the specified version does not exist, it will be consed and mared as a temporary definition." (let ((class-val-symbol (class-val-symbol name version)) (temp)) (if (boundp class-val-symbol) (symeval class-val-symbol) ;All done! (setq temp (si:create-class name name '(SI:TEMP-CLASS) ':error ':normal '((temp-flag . #t)) version t))) (ensure-value-cell class-val-symbol) ;SET can cons 4V sell (if (boundp class-val-symbol) (symeval class-val-symbol) (if (boundp class-val-symbol) (symeval class-val-symbol) (set class-val-symbol temp))))) ;; Initial class objects, flavorized. (herald ICLASS) (dolist (foo '( (def-initial-class OBJECT ()) (def-initial-class PRIMITIVE (OBJECT)) (def-initial-class NUMBER (OBJECT)) (def-initial-class INTEGER (NUMBER)) (def-initial-class FIXNUM (INTEGER PRIMITIVE)) (def-initial-class BIGNUM (INTEGER)) (def-initial-class POSITIVE-BIGNUM (BIGNUM)) (def-initial-class NEGATIVE-BIGNUM (BIGNUM)) (def-initial-class FLOAT (NUMBER)) (def-initial-class FLONUM (FLOAT PRIMITIVE)) (def-initial-class FLONUM-S (FLOAT PRIMITIVE)) (def-initial-class SMALL-FLONUM (FLOAT PRIMITIVE)) (def-initial-class CONSTANT (OBJECT PRIMITIVE)) (def-initial-class SEQUENCE (OBJECT)) (def-initial-class Q-SEQUENCE (SEQUENCE)) (def-initial-class LIST (Q-SEQUENCE)) (def-initial-class PAIR (LIST PRIMITIVE)) (def-initial-class NULL (CONSTANT LIST PRIMITIVE)) (def-initial-class VECTOR-SEQUENCE (Q-SEQUENCE)) (def-initial-class VECTOR (VECTOR-SEQUENCE PRIMITIVE)) (def-initial-class STACK-VECTOR (VECTOR)) (def-initial-class MODULE-VECTOR (VECTOR)) (def-initial-class EXTEND (VECTOR-SEQUENCE PRIMITIVE)) (def-initial-class STRING (SEQUENCE PRIMITIVE)) (def-initial-class MODULE-STRING (STRING)) (def-initial-class BITS (SEQUENCE PRIMITIVE)) (def-initial-class SYMBOL (PRIMITIVE)) (def-initial-class CHARACTER (PRIMITIVE)) (def-initial-class CELL (PRIMITIVE)) (def-initial-class UNBOUND (PRIMITIVE)) (def-initial-class MSUBR (PRIMITIVE)) (def-initial-class GC-FORWARD (PRIMITIVE)) (def-initial-class SUBR (PRIMITIVE)) (def-initial-class MODULE (PRIMITIVE)) )) (let* (((name superiors . rest) (cdr foo)) (varname (package-symbolconc "GLOBAL" name '-class))) (lexpr-funcall #'defflavor1 name () superiors ':flavor-not-instantiable rest) (putprop varname #T 'special) (set varname (flavor-structure name)))) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; END: X;;; PRINTER -*-Mode:LISP; Package:SI-*- ;;; ************************************************************** ;;; ***** NIL ****** The External-syntax Generator *************** ;;; ************************************************************** ;;; ** (C) Copyright 1981 Massachusetts Institute of Technology ** ;;; ****** This is a read-only file! (All writes reserved) ******* ;;; ************************************************************** ;;; The following variables must be on SI:INTERRUPT-BOUND-VARIABLES ;;; SI:PRINT-FIXNUM-BUFFER (eval-when (eval compile) (cond ((status feature MACLISP) (cond ((status nofeature FOR-NIL) (sstatus feature FOR-MACLISP) (sstatus feature FM))) (or (boundp '*:PTR-TYPEP-TABLE) (load '((VM) TYPES))))) ) (herald PRINTER /3) #-FM (globalize "PRINT" "PRINC" "PRIN1" "OUSTR" ) (declare (special si:interior-slashp-table si:alt-mode-char si:print-dispatch-table si:print-fixnum-buffer)) ;;; these should be auto-specialized by the compiler (declare (special PACKAGE GLOBAL-PACKAGE SYSTEM-INTERNALS-PACKAGE USER-PACKAGE KEYWORD-PACKAGE *-PACKAGE STANDARD-OUTPUT STANDARD-OUTPUT-RADIX SI:INTERRUTP-BOUND-VARIABLES *:PTR-TYPEP-TABLE)) ;;;; Some temporary macros (eval-when (eval compile) (defmacro SLASH-IF-INTERIOR? (ch) `(BIT1P SI:INTERIOR-SLASHP-TABLE ,ch)) ) (if (boundp 'SI:INTERRUPT-BOUND-VARIABLES) (push 'SI:PRINT-FIXNUM-BUFFER SI:INTERRUPT-BOUND-VARIABLES)) ;;;; Some permanent table setups (setq-if-unbound STANDARD-OUTPUT 'T SI:ALT-MODE-CHAR ~\ALT) (setq SI:PRINT-FIXNUM-BUFFER (make-string 32.)) (setq SI:INTERIOR-SLASHP-TABLE (let ((bv (make-bits 128.)) bit) (dovector (byte #(#b11111111 ;^@-^G #b01111111 ;^H-^O #b11111111 ;^P-^W #b11101111 ;^X-^_ #b10110001 ;sp !"#$%&' ;" #b11001001 ;()*+,-./ #b00000000 ;0-7 #b00110000 ;89:;<=>? #b00000000 ;@ABCDEFG #b00000000 ;HIJKLMNO #b00000000 ;PQRSTUVW #b00000000 ;XYZ[\]^_ #b11111111 ;`abcdefg #b11111111 ;hijklmno #b11111111 ;pqrstuvw #b11101011 ;xyz{|}~ rubout ;| ) j ;;"j" indexes bytes of vector ) (dotimes (k 8) ;; numbering bits from hi to lo in 8-bit integer (setq bit (load-byte byte (- 7 k) 1)) ;; then storeing into an 16.-by-8. bit array (rplacbit bv (+ (* j 8) k) bit))) bv)) (setq SI:PRINT-DISPATCH-TABLE (make-vector (vector-length *:PTR-TYPEP-TABLE))) (dotimes (i (vector-length SI:PRINT-DISPATCH-TABLE)) (vset SI:PRINT-DISPATCH-TABLE i (caseq (vref *:PTR-TYPEP-TABLE i) (FIXNUM #'print-fixnum) (SYMBOL #'print-symbol) (PAIR #'print-list) (STRING #'print-string) ((VECTOR VECTOR-S VECTOR) #'print-vector) (CHARACTER #'print-char) (CONSTANT #'print-constant) (SUBR (if (fboundp 'print-subr) #'print-subr) #'print-constant) (BITS #'print-bits) ((FLONUM FLONUM-S) #'print-flonum) (EXTEND ;;; ######## someday, fetch the print method out of the frob #'print-random) (T #'print-random)))) ;;;; PRINT, PRINC, PRIN1, OUSTR, TERPRI etc (defun PRINT (x &optional (stream STANDARD-OUTPUT)) (terpri stream) (prin1a x stream #T) (oustr " " stream) 'T) (defun PRINC (x &optional (stream STANDARD-OUTPUT)) (prin1a x stream () )) (defun PRIN1 (x &optional (stream STANDARD-OUTPUT)) (prin1a x stream #T)) (defun TERPRI (&optional (stream STANDARD-OUTPUT)) ;;Someday, this may have to be relativised on a per-operating-system basis. (ouch ~\CR stream) (ouch ~\LF stream) () ) (defun PRIN1A (ob stream slashifyp) (cond ((null ob) (oustr "()" stream)) ((eq ob #T) (oustr "#T" stream)) ((funcall (vref SI:PRINT-DISPATCH-TABLE (*:nptr-typep ob)) ob stream slashifyp))) 'T) (defun OUSTR (str &optional (stream STANDARD-OUTPUT) (start 0) (cnt () cntp) &aux len) (cond (*RSET (msetq-call (str start cnt) (check-subsequence 'OUSTR 'STRING str start cnt cntp))) (#T (setq len (string-length str)) (cond ((not cntp) (setq cnt (- len start))) ((not (<= (+ start cnt) len)) (setq cnt (- len start)))))) (dotimes (i cnt) (ouch (char str (+ i start)) stream)) 'T) ;;;; PRINT-SYMBOL (defun PRINT-SYMBOL (ob stream slashifyp) (if (not slashifyp) (oustr (get-pname ob) stream) (let ((/1st-slash) (pn (get-pname ob)) (pkg (si:symbol-package-prefix ob))) (unless (null pkg) (if (not (= (string-length pkg) 0)) (oustr pkg stream)) (ouch ~/: stream)) (cond ((null (setq /1st-slash (si:sym-1st-slash pn))) (oustr pn stream)) ((< /1st-slash 0) (print-string pn stream #T ~/|)) ((let ((n (string-length pn)) (char)) (dotimes (i n) (setq char (char-n pn i)) (if (or (= i /1st-slash) (slash-if-interior? char)) (ouch ~// stream)) (ouch (*:fixnum-to-character char) stream)))))))) (defun SI:SYM-1ST-SLASH (pn &aux (n (string-length pn))) "Index of first char to slashify in a symbol's pname () if no slashification at all, -1 if |---| is best else fixnum index of 1st char to be slashed" (declare (fixnum i n)) (if (= n 0) -1 ;null pname, use || (let ((all-digits 'T) char /1st-slash leading-sign) (dotimes (i n) (setq char (char-n pn i)) (if (slash-if-interior? char) (cond ((or /1st-slash ;> 1 slashes, use || (= char #/.) (= char #\SPACE) ;If format effectors (= char #\TAB) ; appear, then use || (= char #\NEWLINE) (= char #\FORM)) (return (setq /1st-slast -1))) (#T (setq all-digits () /1st-slash i) )) (cond ((= i 0) ;leading character (cond ((or (= char #/+) (= char #/-) (= char #/.)) (setq leading-sign char)) ((<= #/0 char #/9)) ((<= #/A char ~/Z) (setq all-digits () )) (#T (setq all-digits () )))) (all-digits (cond ((or (= char #/^) (= char #/_) (= char #/.)) (return (setq /1st-slash 0))) ((<= #/0 char #/9)) (#T (setq all-digits () ))))))) (cond (1st-slash) ;Found 1st slash index - use it (leading-sign ;Could this be parsed as a (cond ((= n 1) ; number? then slash first (if (= leading-sign #/.) 0)) (all-digits 0))) (all-digits 0) ;if all digits, slash the 1st (#T () ))))) (defun SI:SYMBOL-PACKAGE-PREFIX (sym &optional (shortp #T) &aux (pkg (si:symbol-package sym))) (cond ((eq p keyword-package) "") ((or (eq p global-package) (eq p user-package) (eq p package)) ()) ((eq p system-internals-package) (if shortp "SI" "SYSTEM-INTERNALS")) ((eq p *-package) "*") (#T "?"))) ;;; Auxillary print functions, like PRINT-foo for various "foo" (defun PRINT-STRING (x stream slashifyp &aux char) (cond ((null slashifyp) (oustr x)) (#T (ouch ~/" stream) (dotimes (i (string-length x)) (setq char (char x i)) (if (or (eq char ~//) (eq char ~/")) (ouch ~// stream)) (ouch char stream)) (ouch ~/" stream))) #T) (defun PRINT-LIST (l stream slashifyp) (ouch ~/( stream) (do ((l l (cdr l))) ((atom l) (cond ((null l) (ouch ~/) stream)) (#T (oustr " . " stream) (prin1a l stream slashifyp) (ouch ~/) stream))) #T) (prin1a (car l) stream slashifyp) (when (not (atom (cdr l))) (oustr " " stream)))) (defun PRINT-VECTOR (v stream slashifyp &aux (n (vector-length v))) (cond ((= 0 n) (oustr "#()" stream)) (#T (oustr "#(" stream) (dotimes (i (1- n)) (prin1a (vref v i) stream slashifyp) (ouch ~/ stream)) (prin1a (vref v (1- n)) stream slashifyp) (ouch ~/) stream))) #T) (defun PRINT-FIXNUM (n stream () ) (print-fixnum-1 n stream STANDARD-OUTPUT-RADIX) (and (null *NOPOINT) (= STANDARD-OUTPUT-RADIX 10.) (ouch ~/. stream)) #T) (defun PRINT-FIXNUM-1 (n stream radix) (declare (fixnum n i d)) (cond ((= n 0) (oustr "0" stream)) ((let ((haumany 0) (bln (string-length SI:PRINT-FIXNUM-BUFFER)) first-hi) (declare (fixnum haumany bln)) (cond ((>= n 0)) (#T (ouch ~/- stream) ;Fixup for negative nums (if (= n *:MIN-FIXNUM) (setq first-hi #T n 1) (setq n (- n))))) (do ((i 0 (1+ i)) ;Loop to fill in buffer with (d 0)) ; digits in reverse order ((<= n 0) (setq haumany i)) ;Remember how many digits (cond (first-hi (multiple-value (n d) (si:fulldiv 0 1 radix)) (setq first-hi () )) (#T (multiple-value (n d) (si:fulldiv n 0 radix)))) ;;Get next digit and reduce input (if (>= i bln) (ferror () "FIXNUM with more than 32 digits?")) (rplachar-n SI:PRINT-FIXNUM-BUFFER i (+ d (if (<= d 9) #/0 (- #/A 10.))))) (do i (1- haumany) (1- i) (< i 0) (setq n (char-n SI:PRINT-FIXNUM-BUFFER i)) (ouch (*:fixnum-to-character n) stream))))) #T) (defun PRINT-BITS (ob stream slashifyp) (oustr "#B/"" stream) (dotimes (i (bits-length ob)) (ouch (if (bit1p ob i) ~/1 ~/0) stream)) (ouch ~/") #T) (defun PRINT-CONSTANT (ob stream slashifyp) (cond ((null ob) (oustr "()" stream)) ((eq ob #T) (oustr "#T" stream)) ((subrp ob) (oustr "# stream)) ((let ((afm-num (si:argframe-marker-p ob))) (cond (afm-num (oustr "#!AFM-" stream) (print-fixnum-1 afm-num stream 10.) (oustr "!" stream)) (#T (oustr "# stream)))))) 'T) (defun PRINT-FLONUM (ob stream slashifyp) (error '|Can't yet print flonums|)) (defun PRINT-CHAR (ob stream slashifyp) (when slashifyp (oustr "~//" stream)) (ouch ob stream)) (comment | (defun print-char (ob stream slashifyp) (when slashifyp (oustr "~//" stream)) (cond ((eq ob ~/ (oustr "^?" stream)) ((>= (*:character-to-fixnum ob) #\SPACE) (ouch ob stream)) ((eq ob SI:ALT-MODE-CHAR) (ouch ~/$ stream)) ;dollar-sign for alt-mode (#T (ouch ~/^ stream) (ouch (*:fixnum-to-character (logxor #.(logxor #/A #^A) (*:character-to-fixnum ob))) stream)))) |) (defun PRINT-RANDOM (ob stream slashifyp) (declare (ignore slashifyp)) ;;; ###### Someday, develop this further, especially for BIGNUMS. (oustr (cond ((eq ob GLOBAL-PACKAGE) "#{PACKAGE GLOBAL}") ((eq ob USER-PACKAGE) "#{PACKAGE USER}") ((eq ob SYSTEM-INTERNALS-PACKAGE) "#{PACKAGE SI}") ((eq ob KEYWORD-PACKAGE) "#{PACKAGE KEYWORD}") ((eq ob *-PACKAGE) "#{PACKAGE *}") (#T "#?RANDOM")) stream)) ;;; NILIO -*- Package: System-Internals; Mode: LISP -*- ;;; ************************************************************** ;;; ********* NILIO ****** Input/output functions **************** ;;; ************************************************************** ;;; ** (C) Copyright 1980 Massachusetts Institute of Technology ** ;;; ****** This is a read-only file! (All writes reserved) ******* ;;; ************************************************************** ;;; CONTENTS ;;; Stream operations ;;; Printer (MODULE NILIO) ;make the simulator happy (HERALD NILIO) ;print load message (comment INCH OUCH PRINT etc) (defun IN (stream) (si:stream-inbuffer-op stream 'FIXNUM 'T () )) (defun INCH (&OPTIONAL (stream STANDARD-INPUT) (peekarg *:eof-character)) (si:stream-inbuffer-op stream 'CHARACTER 'T peekarg)) (defun INCHPEEK (&OPTIONAL (stream STANDARD-INPUT) (peekarg *:eof-character)) (si:stream-inbuffer-op stream 'CHARACTER () peekarg)) (defun OUCH (char &OPTIONAL (stream STANDARD-OUTPUT)) (si:output-byte (*:character-to-fixnum char) stream) ;Someday, try writing the STREAM-OUTBUFFER-OP, keyed on the predicate ; (or (memq stream '(() T)) (eq stream TYO)) ) (defun OUSTR (str &OPTIONAL (stream STANDARD-OUTPUT)) (do ((n (string-length str)) (i 0 (1+ i))) ((not (< i n)) () ) (si:output-byte (*:character-to-fixnum (char str i)) stream))) (declare (special stream no-slashify-flag)) ;## hack PRINLEVEL and PRINLENGTH! (defun si:prin-1-ob (ob) (typecaseq ob (PAIR (si:prin-list ob stream)) (SYMBOL (si:prinsymbol (not no-slashify-flag) ob stream)) (FIXNUM (si:prinnumber 'FIXNUM ob stream)) ((FLONUM FLONUM-S) (si:prinnumber 'FLONUM ob stream)) (CHARACTER (oustr "~//" stream) (ouch ob stream)) ((VECTOR VECTOR-S) (si:prin-vector ob stream)) (STRING (si:prin-string ob stream)) (BITS (si:prin-bits ob stream)) (CONSTANT (cond ((null ob) (oustr "()" stream)) ((eq ob #T) (oustr "#T" stream)) ((let ((? (rassq ob si:constants-table))) (cond (? (oustr "#!" stream) (oustr (car ?) stream) (ouch ~/! stream)) ('T (error '|Lost CONSTANT - PRINT|))))))) (SMALL-FLONUM (si:prin-small-flonum ob stream)) (SUBR (si:prin-subr ob stream)) (EXTEND (si:prin-extend ob stream)) #+MACLISP (T (oustr "#?" stream) ;; change this to error gunk later (#@PRIN1 ob stream) )) #T ) (defvar si:prin-level *:max-fixnum) (defun SI:PRIN-LIST (ob stream) (let ((si:prin-level (1- si:prin-level))) (cond ((-p si:prin-level) (ouch ~/# stream)) ('t (ouch ~/( stream) (si:prin-1-ob (car ob)) (do ((obs (cdr ob) (cdr obs)) (len (1- (or prinlength *:max-fixnum)) (1- len))) ((null obs) #T) (declare (fixnum len)) (cond ((<= len 0) (oustr " ..." stream) (return () )) ((not (pairp obs)) (oustr " . " stream) (si:prin-1-ob obs) (return () ))) (ouch ~/ stream) (si:prin-1-ob (car obs))) (ouch ~/) stream))))) (defun SI:PRIN-VECTOR (ob stream) (let ((si:prin-level (1- si:prin-level))) (cond ((-p si:prin-level) (ouch ~/# stream)) ;;For the time being, named structures appear as vectors ((and (struct-typep ob) (boundp 'si:struct-hack) si:struct-hack) (SI:PRIN-STRUCT ob stream)) ('t (oustr "#/(" stream) (do ((i 0 (1+ i)) (mx (vector-length ob)) (firstp 'T)) ((not (< i mx))) (declare (fixnum mx i)) (cond ((and prinlength (>= i prinlength)) (oustr " ..." stream) (return () )) ((not firstp) (ouch ~/ stream))) (setq firstp () ) (si:prin-1-ob (vref ob i))) (ouch ~/) stream))))) (defun SI:PRIN-STRUCT (ob stream) (let* ((typ (struct-typep ob)) (inis (struct=info-inis (get typ 'struct=info)))) (oustr "#{STRUCT " stream) (prin1 typ stream) (do i 1 (1+ i) (>= i (vector-length inis)) ; (format stream " ~S ~S" (car (vref inis i)) (cadr (vref inis i))) (ouch ~/ stream) (prin1 (car (vref inis i)) stream) (ouch ~/ stream) (prin1 (vref ob (cadr (get (cadr (vref inis i)) 'selector))) stream)) (ouch ~/} stream))) (defun SI:PRIN-STRING (ob stream) (cond (no-slashify-flag (oustr ob stream)) ('t (ouch ~/") (do ((i 0 (1+ i)) (mx (string-length ob))) ((not (< i mx))) (declare (fixnum mx i)) (let ((ch (char ob i))) (and (not no-slashify-flag) (or (eq ch ~/") (eq ch ~//)) (ouch ~// stream)) (ouch ch stream))) (ouch ~/")))) ;Print at most PRINLENGTH bytes, if PRINLENGTH is nonnull. (defun SI:PRIN-BITS (ob stream &aux abbrev (nbits (bits-length ob))) (cond ((and prinlength (> nbits (* prinlength *:bits-per-byte))) (setq nbits (* prinlength *:bits-per-byte) abbrev #T))) (oustr "#B/"" stream) (do ((i 0 (1+ i))) ((not (< i nbits))) (declare (fixnum mx i)) (ouch (if (= (bit ob i) 0) ~0 ~1) stream)) (and abbrev (do i 1 (1+ i) (> i 3) (ouch ~/. stream))) (ouch ~/" stream)) (defun SI:PRIN-EXTEND (ob stream) (let ((type (typep ob))) (oustr "#{" stream) (princ type stream) (caseq type (CLASS (ouch ~/ ) (prin1 (vref ob *:class-typep-index))) (PACKAGE (ouch ~/ ) (oustr (pkg-name ob)))) (ouch ~/} stream))) (defun SI:PRIN-SUBR (ob si:stream) (let ((name (si:subr-name ob))) (oustr "#?SUBR" si:stream) (cond (name (ouch ~- si:stream) (prin1 name si:stream))))) ;;; Bind "stream" and "no-slashify-flag" so that si:prin-1-ob can take it easy. (defun PRINT (ob &OPTIONAL (stream standard-output)) (let ((no-slashify-flag ()) (si:prin-level (or prinlevel *:max-fixnum))) (terpri stream) (si:prin-1-ob ob) (ouch ~/ stream) #T)) (defun PRIN1 (ob &OPTIONAL (stream standard-output)) (let ((no-slashify-flag ()) (si:prin-level (or prinlevel *:max-fixnum))) (si:prin-1-ob ob))) (defun PRINC (ob &OPTIONAL (stream standard-output)) (let ((no-slashify-flag #T) (si:prin-level (or prinlevel *:max-fixnum))) (si:prin-1-ob ob))) (FFSETQ *PRIN1 PRIN1) (FFSETQ *PRINT PRINT) (FFSETQ *PRINC PRINC) (comment PUTBACK and I/O Buffer Operations) ;;; ########### We will need the equivalent, for the STREAM datatype, of ;;; (DEFVST STREAM PUTBACKLIST BLOCK.INPUT.FUNCTION TYPE ...) ;;; PUTBACK conses one of the following onto the stream's buffer-back-list: ;;; (SINGLE . item) ;;; (BUFFERKEY . #{BUFFERKEY}( ;;; ;;; )) ;;; (STREAM . ) (defun PUTBACK (type datum stream) (prog (pbslot pbitem) (caseq type ((STREAM BUFFERKEY) (and (not (eq (typep datum) type)) (error 'WTA datum))) (SINGLE () ) (T (error '|"type" unrecognized| type))) (cond ((or (memq stream '(() T)) (eq stream TYO)) ;"T" stands for all ways TTY can be open (setq stream 'T)) ((not (eq (typep stream) 'STREAM)) (error 'WTA stream))) (setq pbslot (assq stream si:putback-alist) ;%%%% (stream-putbacklist stream) %%%% ) (setq pbitem (cons type datum)) (cond ((null pbslot) (push (list stream pbitem) si:putback-alist) ;%%%% (setf (stream-putbacklist stream) pbitem) %%%% ) ('T (rplacd pbslot (cons pbitem (cdr pbslot))) ;%%%% (setf (stream-putbacklist stream) (cons pbitem pbslot)) %%% )) (return stream))) (defun si:stream-inbuffer-op (stream type advancep peekarg) (declare (special si:putback-alist si:unique-msg)) (prog (pbslot pbl data) (setq pbslot (assq stream si:putback-alist)) A (cond ((null (setq pbl (cdr pbslot))) (and pbslot (setq si:putback-alist (delq pbslot si:putback-alist))) (and (not (memq type '(FIXNUM CHARACTER))) (error 'WTA type)) ;;; ########## here, we want to check for a BLOCK mode stream, and call ;;; the block-input function, which is system-dependent. (cond (advancep (caseq type (FIXNUM (setq data (si:input-fixnum stream))) (CHARACTER (setq data (si:input-byte -1 stream)) (setq data (cond ((= data -1) peekarg) ((*:fixnum-to-character data))))))) ((caseq type (FIXNUM (setq data (si:input-fixnum stream)) (putback 'SINGLE data stream)) (CHARACTER (setq data (si:peek-byte peekarg stream))) )))) ('T (cond ((eq (caar pbl) 'SINGLE) (and advancep (rplacd pbslot (cdr pbl))) (setq data (cdar pbl))) ((eq (caar pbl) 'BUFFERKEY) ;See below, under PUTBACK, for buffer formats (let ((i (vref (cdar pbl) 0)) (mx (vref (cdar pbl) 1))) (declare (fixnum i mx)) (cond ((> i mx) (rplacd pbslot (cdr pbl)) (go A))) (setq data (elt (vref (cdar pbl) 2) i)) (cond ((not advancep)) ((> (setq i (1+ i)) mx) (rplacd pbslot (cdr pbl))) ((vset (cdar pbl) 0 i))))) ((eq (caar pbl) 'STREAM) (setq data (si:stream-inbuffer-op (cdar pbl) type 'T si:unique-msg)) (cond ((eq data si:unique-msg) (rplacd pbslot (cdr pbl)) (go A))) (and (not advancep) (putback 'SINGLE data (cdar pbl)))) ('T (error '|Unknown buffer type| (list stream pbl)))) (if (caseq type (CHARACTER (not (characterp data))) (FIXNUM (not (fixnump data))) (T () )) (error '|Wrong type object in stream| (list stream data))))) (return data))) ; Kludgy DEFSETF to go with ZSETF (defmacro defsetf (name (call-form set-val) ignore-flag &body body) (let ((form-var (gentemp 'form))) `(defun (,name losing-setf) (,form-var ,set-val) (let (( ,call-form ,form-var)) ,@body)))) ;;Set SI:LISP-VERSION #.(progn (defprop ifd$w_filnamoff 2 asym) (defprop ihd$w_imgidoff 6 asym) (defprop mmg$imghdrbuf #x+7ffee200 asym) `#(FILE ,(to-string (namestring (truename infile))))) #(LOADRUN setup-lispv (0. 0. 0.) NIL #T) #(WORD 1024.) #(BLBC #(REG SLP CL$TM_POLLP) |POLL..1195|) #(JSB #(@REG SLP CL$MS_INTERRUPT)) |POLL..1195| #(MOVAL #(LREL PC |POLL..1195|) FLP) #(PUSHL #(REG SLP CL$QC_CCFRAME)) #(CMPB #(LIT NIL 3.) #(REG AP 0.)) #(BEQL |OK..1194|) #(JSB #(@REG SLP CL$MS_WNA_ERR)) |OK..1194| #(movl #(lit () mmg$imghdrbuf) r1) ;addr of buffer #(movl #(reg r1 4) r2) ;pointer to offset word #(movzwl #(reg r2 ifd$w_filnamoff) r3) ;offset amount #(addl3 r2 r3 r4) ;r4 = addr of ascic string #(movzbl #(reg+ r4 ()) r3) ;r3 = length of string, r4 -> string #(locc #(lit () #/;) r3 #(reg r4 ())) ;find the ';' delimiting the .EXE version #(decl r0) ;adjust lengths #(incl r1) #(movq r0 #(-reg sp ())) ;save across string cons #(pushl #(shortlit () 2_2)) #(pushl #(reg slp cl$qc_dirt_mark)) #(ashl #(lit () 2) r0 ar1) ;fixnum string length #(jsb #(@reg slp cl$ms_str_cons)) #(addl2 #(lit () 8) sp) ;pop off dirtmark #(movq #(reg+ sp ()) r0) ;len & addr of string source #(movc3 r0 #(reg r1 ()) #(reg ar1 (- tc$k_string))) #(deflink lispv-slink svci si:lisp-version) #(addl3 #(reg flp lispv-slink) slp r0) ;addr of cell #(movl ar1 #(reg r0 ())) #(ret) #(end) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; END: ;;;VAX instruction deassembler ;;Initially used for checkout of the assembler, ;;but perhaps someday this will make part of a debugger. ;;Includes some understanding of VASL file relocation codes (herald DEASS) (eval-when (eval compile) (or (get 'SHARPCONDITIONALS 'version) (load '((lisp) sharpc)))) ;;DO NOT combine this with (eval-when (eval compile) ..) above! ;;This needs to be read AFTER the above takes place. (eval-when (eval compile) (load (when-feature ((local ITS) '((kip) vasdcl)) ((local VMS) '((rlb h) vasdcl)) (T "You lose, bunkie!"))) (or (get 'vaspre 'version) (load (when-feature ((local ITS) '((kip) vaspre)) ((local VMS) '((rlb h) vaspre)) (T "You lose, bunkie!")))) ) (declare (special examine-mode deass-source deass-stream) (*lexpr ei eby ewo elo string-append)) (defvar examine-mode 'insn) (defvar deass-source #b"") (defvar insn-in-pc 0) ;;;; Examination functions (defun e (&optional (loc (insn-in 0))) (caseq examine-mode (insn (ei loc)) (byte (eby loc)) (word (ewo loc)) (long (elo loc)) (T (error '|Huh? - E| examine-mode loc)))) (defun ei (&optional loc) (unless loc (setq loc (insn-in 0))) (format deass-stream "~D: " loc) (examine-insn loc) (get-deass-stream)) (defun eby (&optional loc) (when loc (set-insn-in-PC loc)) (efix loc 1)) (defun ewo (&optional loc) (when loc (set-insn-in-PC loc)) (efix loc 2)) (defun elo (&optional loc) (when loc (set-insn-in-PC loc)) (efix loc 4)) (defun efix (loc size) (unless loc (setq loc (insn-in 0))) (let ((contents (insn-in size))) (format deass-stream "~D: ~D ~Z" loc contents contents)) (get-deass-stream)) (defun ero (&optional loc) (when loc (set-insn-in-PC loc)) (examine-reloc loc) (get-deass-stream)) ;;Set deass-source to subr buffer BITS from a symbol (defun eset (sym) (setq deass-source (let ((s (and (fboundp sym) (fsymeval sym)))) (if (and s (eq (typep s) 'subr)) ;this wants to run in Maclips, too s (buf-buf (subr-info-code (get sym 'subr-info))))))) ;;Set deass-source to bitstring from VASL file #+Maclisp (defun eat-vasl (file) (iota ((f (mergef file '|* VASL|) '(in fixnum))) (let* ((l (lengthf f)) (b (make-bits (* l 4 bits-per-byte)))) (do ((i 0 (1+ i)) (bskip 0 (+ bskip 32))) ((not (< i l)) (setq deass-source b)) (do ((n (in f)) (k 0 (+ k 8))) ((>= k 32)) (set-nibble b (+ bskip k) 8 (load-byte n (- 28 k) 8))))))) #+NIL (defun eat-vasl (file size-in-blocks) (iota ((f (mergef file "*.VAS") '(:in :byte))) (eoffn f #'(lambda (stream) (*throw 'vasl-eof 't))) (let* ((number-of-bytes (* 256 size-in-blocks)) (b (make-bits (* 8 number-of-bytes)))) (*catch 'vasl-eof (do ((i 0 (1+ i)) (j 0 (+ j 8))) ((>= i number-of-bytes)) (set-nibble b j 8 (in f)))) (setq deass-source b)))) ;;;; Instruction decoding (defun examine-insn (loc) (when loc (set-insn-in-PC loc)) (let* ((opcode (insn-in 1)) (insn (vref insn-op-decode-table opcode)) (info (get insn 'insn-info))) (cond ((or (null insn) (null info)) (format deass-stream "Can't decode insn ~2Z at ~D" opcode loc)) (#T (let ((accesses (insn-info-accesses info)) (dtypes (insn-info-dtypes info)) (noprnds (insn-info-noprnds info))) (format deass-stream "~A~A" insn (if (> noprnds 0) " " "")) (dotimes (i noprnds) (when (> i 0) (format deass-stream ",")) (deass-operand (vref dtypes i) (vref accesses i)))))))) (defun deass-operand (dtype access) (cond ((eq access 'branch) (caseq dtype (byte (format deass-stream "+~D" (+ (insn-in -1) (insn-in 0)))) (word (format deass-stream "+~D" (+ (insn-in -2) (insn-in 0)))) (T (format deass-stream "Huh? Branch code ~S at ~D" dtype (insn-in 0))))) (#T (let* ((byte (insn-in 1)) (bmode (load-byte byte 4 4)) (reg (load-byte byte 0 4))) (caseq bmode ((0 1 2 3) (format deass-stream "S^#~D" byte)) (4 (deass-operand dtype access) (format deass-stream "[~A]" (register-name reg))) (5 (princ (register-name reg) deass-stream)) (6 (format deass-stream "(~A)" (register-name reg))) (7 (format deass-stream "-(~A)" (register-name reg))) (T (cond ((= reg 15) (examine-pc-operand bmode dtype)) (#T (caseq bmode (8 (format deass-stream "(~A)+" (register-name reg))) (9 (format deass-stream "@(~A)+" (register-name reg))) (T (format deass-stream "~A^~D(~A)" (vref #("B" "@B" "W" "@W" "L" "@L") (- bmode #X+A)) (insn-in (- (vref #(1 1 2 2 4 4) (- bmode #X+A)))) (register-name reg)))))))))))) (defun examine-pc-operand (bmode dtype) (caseq bmode (8 (format deass-stream "I^#~D" ;Immediate (insn-in (caseq dtype (byte 1) (word 2) ((long floating) 4) ((quad double) 8))))) (9 (format deass-stream "@#~D" (insn-in 4))) (T (let ((str (vref #("B^~D" "@B^~D" "W^~D" "@W^~D" "L^~D" "@L^~D") (- bmode #X+A))) (size (vref #(-1 -1 -2 -2 -4 -4) (- bmode #X+A)))) (format deass-stream str (+ (insn-in size) (insn-in 0))))))) ;;;; Deassemble FLINK relocation section (defun examine-reloc (loc) (when loc (set-insn-in-PC loc)) (let ((code (vdecode (insn-in 1) reloc-decode))) (caseq code (vas$k_nop (format deass-stream "NOP")) (vas$k_ignore (let ((by (insn-in 1))) (set-insn-in-PC (+ by (insn-in 0))) (format deass-stream "Ignore ~D bytes" by))) (vas$k_reloc (let* ((vs (examine-vslot)) (nb (insn-in 1)) (ns (min 40 (* bits-per-byte nb))) (b (make-bits (* bits-per-byte nb))) (s (if (< ns 40) (make-string ns) (string-replace (make-string 43) "..." 40)))) ;;Fill the bit buffer (dotimes (i nb) (set-nibble b (* i bits-per-byte) bits-per-byte (insn-in 1))) ;;Cvt bits to chs (dotimes (i ns) (rplachar s i (if (0p (bit b i)) ~/0 ~/1))) (format deass-stream "Reloc ~D slots at ~A: ~A" (* nb bits-per-byte) vs s))) (vas$k_lspsym (examine-sym-store (format () "Store Lisp symbol /"~A/"" (examine-reloc-string)))) (vas$k_pkgsym (examine-sym-store (format () "Store Lisp symbol, in package /"~A/", pname /"~A/"" (examine-reloc-string) (examine-reloc-string)))) (vas$k_sl_ref (examine-slink-ref "Slink-ref src ~A, cell ~A, dst ~A")) (vas$k_celldef (examine-slink-ref "Cell-def sym ~A, cell ~A, src ~A")) (vas$k_call (format deass-stream "Machine-code call to ~A" (examine-vslot))) (vas$k_end (format deass-stream "End of relocation")) (vas$k_const (format deass-stream "Make ~A into a const" (examine-vslot))) (vas$k_putprop (format deass-stream "DEFPROP ~a ~a ~a" (examine-vslot) (examine-vslot) (examine-vslot))) (#T (format deass-stream "~A" code))))) (defun examine-vslot () (let ((vecn (insn-in 1))) (if (0p vecn) () (format () "~A[~D]" (vdecode vecn vslot-decode) (insn-in 3))))) (defun examine-reloc-string () (let ((n (insn-in 4)) s) (setq s (make-string n)) (dotimes (i n) (rplachar-n s i (insn-in 1))) s)) (defun examine-sym-store (st) (do ((r (examine-vslot) (examine-vslot)) (l)) ((null r) (format deass-stream "~A in ~A" st (nreverse l))) (push r l))) (defun examine-slink-ref (fmt) (let ((src (examine-vslot)) (byt (insn-in 1)) (dst (examine-vslot))) (setq byt (if (and (<= 0 byt) (<= byt 16)) (vref sl-ref-decode byt) (let ((base 10.)) (maknam (exploden byt))))) (format deass-stream fmt ;"~A dst ~A, cell ~A, src ~A" src byt dst))) (defun vdecode (n vec) (if (<= 0 n (1- (vector-length vec))) (vref vec n) (to-symbol (format () "~D" n)))) ;1,2,4 unsigned byte,word,long ;-1,-2,-4 signed byte,word,long ;0 PC (defun set-insn-in-PC (new-PC) (declare (special insn-in-PC)) (setq insn-in-PC new-pc) #T) (defun insn-in (size) (declare (special insn-in-PC)) (if (= size 0) insn-in-PC (let* ((loc (* bytesize insn-in-PC)) (result (caseq size (1 (subr-nibble deass-source loc bytesize)) (2 (subr-nibble deass-source loc wordsize)) (3 (subr-nibble deass-source loc (* 3 bytesize))) #+Maclisp (4 (subr-nibble deass-source loc longsize)) #+NIL (4 (subr-nibble deass-source loc 30)) (-1 (sign-extend-byte (subr-nibble deass-source loc bytesize))) (-2 (sign-extend-word (subr-nibble deass-source loc wordsize))) #+Maclisp (-4 (sign-extend-long (subr-nibble deass-source loc longsize))) #+NIL (-4 (subr-nibble-2c deass-source loc 30)) (T (ferror () "deass:insn-in wrong size ~d" size))))) (inc insn-in-PC (if (< size 0) (- size) size)) result))) (defun subr-nibble (s skip take) (nibble (if (bitsp s) s (si:change-type s 'bits)) skip take)) (defun subr-nibble-2c (s skip take) (nibble-2c (if (bitsp s) s (si:change-type s 'bits)) skip take)) (defun sign-extend-byte (n) (if (bit-test 1_7 n) (bit-or n -1_7) n)) (defun sign-extend-word (n) (if (bit-test 1_15 n) (bit-or n -1_15) n)) #+Maclisp (defun sign-extend-long (n) (if (bit-test 1_31 n) (bit-or n -1_31) n)) (defun register-name (n) (declare (special register-names)) (unless (boundp 'register-names) (setq register-names (make-vector 16.)) (dolist (r '(R0 R1 R2 R3 R4 R5 AR1 AR2 AR3 FLP SLP AP FP SP PC)) (let ((rn (get r 'register))) (if rn (vset register-names rn (get-pname r)) (error '|No REGISTER property| rn 'wrng-type-arg))))) (if (<= 0 n 15.) (vref register-names n) (format () "register~D" n))) #+Maclisp (defprop Z |fmt.Z.op/|| format-ctl-one-arg) #+Maclisp (defun |fmt.Z.op/|| (num params) (let (((ndigs) params) (base 16.)) (cond ((< num 0) (tyo #/- standard-output) (setq num (explodec (- num))) (when ndigs (setq ndigs (1- ndigs)))) ((= num 0) (setq num '(/0))) ((> num 0) (setq num (explodec num)))) (when (memq (car num) '(A B C D E F)) (push '/0 num)) (when ndigs (do i (length num) (1+ i) (>= i ndigs) (princ '|0| standard-output))) (mapc #'(lambda (x) (princ x standard-output)) num))) (defmacro deass-stream-buf (x) `(sfa-get ,x 0)) (defmacro deass-stream-index (x) `(sfa-get ,x 1)) (defun deass-stream-handler (self op data) (let ((maxbuf 80.)) (caseq op (:ouch (let ((n (1+ (deass-stream-index self)))) (when (< n maxbuf) (setf (deass-stream-index self) n) (rplachar (deass-stream-buf self) (1- n) data)))) ((tyo :tyo) (sfa-call self ':ouch (code-char data))) (get (let ((result (string-subseq (deass-stream-buf self) 0 (deass-stream-index self)))) (setf (deass-stream-index self) 0) result)) (init (setf (sfa-get self 0) (make-string maxbuf)) (setf (sfa-get self 1) 0) self) ((which-operations :which-operations) '(:ouch tyo :tyo get init)) (T (cerror #T () ':unhandled-sfa-operation "DEASS-STREAM can't handle ~s with ~s" op data)) ))) (defun get-deass-stream () (sfa-call deass-stream 'get 0)) (setq deass-stream (let ((sfa (sfa-create #'deass-stream-handler 2 "deass-stream"))) (sfa-call sfa 'init 0)) ;"stringifier for deassembly" ) ;; Local Modes: ;; Mode:LISP ;; Comment Column:40 ;; Atom Word Mode:1 ;; END: