diff --git a/Makefile b/Makefile index f9766080..db70998f 100644 --- a/Makefile +++ b/Makefile @@ -26,7 +26,7 @@ SRC = syseng sysen1 sysen2 sysen3 sysnet kshack dragon channa \ draw wl taa tj6 budd sharem ucode rvb kldcp math as imsrc gls demo \ macsym lmcons dmcg hack hibou agb gt40 rug maeda ms kle aap common \ fonts zork 11logo kmp info aplogo bkph bbn pdp11 chsncp sca music1 \ - moon + moon teach DOC = info _info_ sysdoc sysnet syshst kshack _teco_ emacs emacs1 c kcc \ chprog sail draw wl pc tj6 share _glpr_ _xgpr_ inquir mudman system \ xfont maxout ucode moon acount alan channa fonts games graphs humor \ diff --git a/build/lisp.tcl b/build/lisp.tcl index 60cfd27f..7c99a8da 100644 --- a/build/lisp.tcl +++ b/build/lisp.tcl @@ -1042,3 +1042,24 @@ respond "*" ":complr\r" respond "_" "kle;forth\r" respond "_" "\032" type ":kill\r" + +# ULisp +respond "*" ":complr\r" +respond "_" "teach; ulisp\r" +respond "_" "\032" +type ":kill\r" +respond "*" ":lisp\r" +respond "Alloc?" "n\r" +respond "*" "(load '((teach) ulisp))" +expect -re {\n[1-7]} +respond "\n" {(dump "teach; ts ulisp")} +respond ":" "t\r" +respond ":" "emacs\r" +respond ":" "edit\r" +respond ":" "script\r" +respond ":" "nil\r" +respond ":" "nil\r" +respond ":" "t\r" +respond ":" "t\r" +respond "\n" ":vk\r" +respond "*" ":kill\r" diff --git a/build/misc.tcl b/build/misc.tcl index 42124dd9..0d3e69cd 100644 --- a/build/misc.tcl +++ b/build/misc.tcl @@ -13,9 +13,6 @@ respond "*" "purify\033g" respond "TS MIDAS" "midas;ts 324\r" respond "*" ":kill\r" -respond "*" ":print teach;..new. (udir)\r" -type ":vk\r" - respond "*" ":link teach;teach emacs,emacs;teach emacs\r" type ":vk\r" respond "*" "teach\033\023" diff --git a/doc/programs.md b/doc/programs.md index 6999beed..80f76cd0 100644 --- a/doc/programs.md +++ b/doc/programs.md @@ -264,6 +264,7 @@ - TTYSWP, swap TTYs. - TYPE8, type 8-bit file. - UFIND, find users. +- ULISP, Lisp in Lisp. - UNTALK, split-screen comm-link program. - UP/DOWN, check if host is online. - UPTIME, Chaosnet uptime server. diff --git a/src/teach/ulisp.459 b/src/teach/ulisp.459 new file mode 100755 index 00000000..d555e919 --- /dev/null +++ b/src/teach/ulisp.459 @@ -0,0 +1,2163 @@ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; +;;; ULISP: A Lisp in Lisp ;;; +;;; ;;; +;;; This dialect is for teaching, not for production ;;; +;;; ;;; +;;; Written by Kent Pitman, Summer 1980 ;;; +;;; for use with MIT's 6.001 class ;;; +;;; ;;; +;;; (c) 1980, 1981 Massachusetts Institute of Technology ;;; +;;; ;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;; Declarations + +(HERALD ULISP "") ; Announce loading package + +(ALLOC '(HUNK4 10000. HUNK8 10000.)) ; Allocate Maclisp HUNK space + +(DECLARE (GENPREFIX COMPLR-AUX-)) ; What to call aux functions + +(EVAL-WHEN (EVAL COMPILE) ; Load IOTA file manipulation + (COND ((NOT (STATUS FEATURE IOTA)) ; package + (COND ((EQ (STATUS FILES) 'ITS) + (LOAD "DSK:LIBLSP;IOTA FASL")) + (T + (LOAD "LISP:IOTA.FASL")))))) + +(EVAL-WHEN (COMPILE) ; Don't output macro defs + (SETQ DEFMACRO-FOR-COMPILING NIL)) ; to FASL file. + +(DECLARE ; Decls for the "@" document lister program + (@DEFINE DEFINE |ULisp Function|) + (@DEFINE IMPORT |ULisp Function (imported)|) + (@DEFINE MU-IMPORT |ULisp Function (synonym)|) + (@DEFINE DEF-SPECFORM |ULisp Special Form|) + (@DEFINE DEF-DATATYPE |ULisp Datatype|) + (@DEFINE DEF-EVHOOK |ULisp Evaluation Hook|) + (@DEFINE DEF-DEBUG-OPTION |ULisp Debug Option|) + (@DEFINE DEFMACRO MACRO) + (@DEFINE EQUIVALENCE EXPR)) + +(DECLARE (SPECIAL ; Variable decls for the Maclisp compiler + ; System + *ULISP* ; Flag saying if ULisp is on the stack + *ULISP-FEATURES* ; String describing features for greeting msg + *TOPLEVEL-FLAGS* ; Flags that must be rebound in breakpoints + *TOPLEVEL-VALUES* ; Values those flags should be rebound to + *SYSDEBUG* ; Flag saying this system is being debugged + *EVAL-BEFORE-DUMP* ; Forms to eval before dumping + *EVAL-AFTER-DUMP* ; Forms to eval after dumping + ; Debugging + *BACKLIST* ; A list of things on the stack + *DEBUG* ; Controls auto-breaking on errors + *BREAK-LEVEL* ; How many breakpoints are pending + *ERRFRAME* ; Error frame + ; Editting + *EDITOR-JOB-NAME* ; Job name of editor for ^E to use + *EDITOR-COMM-FILE* ; File for editor to communicate through + ; Evaluator + *ENV* ; Dynamic alist for dynamic evaluation + *LEX* ; Says if lexical scoping is in effect + ; Pseudo Read/Print Operations + *EXPLODED* ; Free variable for chars from explode + *EXPLODE-SFA* ; Holds sfa for doing micro explosions + *IMPLODABLE* ; Holds chars for implode to read + *IMPLODE-SFA* ; Holds sfa for doing micro implosions + *FLATSIZE* ; Free variable that counts flatsize + *FLATSIZE-SFA* ; Holds sfa for doing micro flatsize + ; Reader/Printer + *IBASE* ; Input Radix + *OBASE* ; Output Radix + *PRINLENGTH* ; The printer max iteration depth or () + *PRINLEVEL* ; The printer max recursion depth or () + *PRINLEVEL-COUNT* ; Depth printed to thus far (non-negative) + *SLASHIFY* ; Controls print slashification + ; I/O Streams + *OUTSTREAM* ; All output should go to this stream + *OUTSTREAMS* ; A list of files to output to by default + *SCRIPT-NAME* ; A filename to which we can write scripts + *SCRIPT-STREAM*)) ; A script stream if one is open, else () + +(SETQ ; Init variables used while this file loads + *DEBUG-OPTIONS* () ; List of options used by the debugger + *ENV* () ; Global environment used by MU-SET, MU-EVAL + *TOPLEVEL-FLAGS* () ; Special vars to be rebound in break loops + *TOPLEVEL-VALUES* ()) ; Values to bind them to + +;;;; System creation + +;;; (DUMP filename) dumps out lisp job filename. On non-ITS sites, this will +;;; only return to the monitor where the dump must be done explicitly (eg, +;;; by SAV on 20X). +;;; +;;; Requests a script filename default before dumping. This allows debugging +;;; to be done scripting to a different file than is used by the system once +;;; dumped. + +(DEFUN DUMP-SET (NAME PROMPT) + (FORMAT T "~%~A: " PROMPT) + (SET NAME (READ))) + +(DEFUN DUMP (FILE) + (DUMP-SET '*LEX* "Lexical Scope (T or ())") + (DUMP-SET '*EDITOR-JOB-NAME* "Editor JName (jname or ())") + (DUMP-SET '*EDITOR-COMM-FILE* "Editor Communication Filename") + (DUMP-SET '*SCRIPT-NAME* "Script Filename") + (DUMP-SET '*PRINLEVEL* "Prinlevel (fixnum or ())") + (DUMP-SET '*PRINLENGTH* "Prinlength (fixnum or ())") + (DUMP-SET '*DEBUG* "UserDebug (T or ())") + (DUMP-SET '*SYSDEBUG* "SysDebug (T or ())") + (MAPC #'EVAL *EVAL-BEFORE-DUMP*) ; Eval pre-dump forms + (GC) ; Garbage Collect (Save Space) + (SSTATUS FLUSH (STATUS FEATURE ITS)) ; Full dump on non-ITS + (SUSPEND "" FILE) ; Dump ourselves out + (MAPC #'EVAL *EVAL-AFTER-DUMP*) ; Eval post-dump forms + (COND ((STATUS FEATURE ITS) ; Set file defaults + (DEFAULTF `((DSK ,(STATUS UDIR)) _FOO_ >))) + (T + (DEFAULTF `((PS ,(STATUS UDIR)) FOO LSP /0)))) + (SETQ *EDITOR-COMM-FILE* + (MERGEF *EDITOR-COMM-FILE* DEFAULTF)) + (SSTATUS TOPLEVEL '(ULISP)) ; Enable ULisp Toplevel + '*) + +(DEFUN ULISP () + (FORMAT *OUTSTREAM* "~%;~AULisp.~A ~Ain MacLisp.~A~%" + (IF *LEX* "Lexically scoped " "") + (GET 'ULISP 'VERSION) + *ULISP-FEATURES* + (STATUS LISPV)) + (MU-SET '%IN '*UNDEFINED*) + (MU-SET '%OUT '*UNDEFINED*) + (MU-READ-EVAL-PRINT-LOOP)) + + +;;;; Miscellaneous Evaluator Support + +;;; (BIND-EVALUATION-ENVIRONMENT ...) binds *BACKLIST* to a data-structure +;;; of useful debugging info. +;;; +;;; The BACKLIST is implemented via HUNKs. It should only be accessed +;;; via these operations, so that it is never accidentally picked up by +;;; some other part of the system. + +(DEFMACRO BIND-EVALUATION-ENVIRONMENT (FORM &REST BODY) + `(LET ((*BACKLIST* (HUNK ,FORM *ENV* *BACKLIST*))) + ,@BODY)) + +(DEFMACRO BACKLIST-ENV (X) `(CXR 2. ,X)) +(DEFMACRO BACKLIST-FORM (X) `(CXR 1. ,X)) +(DEFMACRO BACKLIST-PARENT (X) `(CXR 0. ,X)) + +;;; The ERRFRAME system is implemented via hunks, also. +;;; This is for dynamic storage of info about error contexts. + +(DEFMACRO ERROR-FRAME (MESSAGE DATA OLD-ERROR-FRAME BACKLIST) + `(HUNK ,MESSAGE ,DATA ,OLD-ERROR-FRAME ,BACKLIST)) + +(DEFMACRO ERROR-MESSAGE (FRAME) `(CXR 1. ,FRAME)) +(DEFMACRO ERROR-DATA (FRAME) `(CXR 2. ,FRAME)) +(DEFMACRO ERROR-FRAME-PARENT (FRAME) `(CXR 3. ,FRAME)) +(DEFMACRO ERROR-FRAME-BACKLIST (FRAME) `(CXR 0. ,FRAME)) + +;;; +;;; Note: All other uses of HUNKs in this system are extended datatypes. + +;;; The following are abstractions for useful predicates needed by +;;; our system. +;;; +;;; (FIXNUM? object) returns T if X is a fixnum, () otherwise. +;;; (LIST? object) returns T if X is () or a cons +;;; (QUOTED? object) returns T if (CAR object) is the symbol QUOTE. +;;; (MU-FORMAT string arg1 ...) like FORMAT but output stream is *OUTSTREAM* + +(DEFMACRO FIXNUM? (X) `(EQ (TYPEP ,X) 'FIXNUM)) ; For compile-time use +(DEFUN FIXNUM? (X) (EQ (TYPEP X) 'FIXNUM)) ; For run-time use + +(DEFMACRO LIST? (X) `((LAMBDA (X) (OR (NOT X) (EQ (TYPEP X) 'LIST))) ,X)) +(DEFUN LIST? (X) (OR (NOT X) (EQ (TYPEP X) 'LIST)) ) + +(DEFMACRO QUOTED? (X) `(EQ (CAR ,X) 'QUOTE )) + +(DEFMACRO MU-FORMAT (&REST ARG-LIST) `(FORMAT *OUTSTREAM* ,@ARG-LIST)) + +;;; (MU-CHECK-ARGS fn obj1 ob2 ...) +;;; fn is a predicate to apply to each of the succeeding args. If +;;; any predicate test fails, then a MICRO-ERROR is signalled. If all +;;; succeed, then T is returned. + +(DEFUN MU-CHECK-ARGS (PRED &REST ARG-LIST) + (MAPC #'(LAMBDA (A) + (IF (NOT (FUNCALL PRED A)) + (MU-ERROR "Wrong Type Arg" A))) + ARG-LIST)) + +;;;; Extended Datatypes + +;;; This system will use the Maclisp HUNK datatype to represent extended +;;; datatypes. This section abstracts out a useful set of primitives for +;;; our use in manipulating them. +;;; +;;; (EXTEND slot0 slot1 ...) - Creates an extend with the given slot values. +;;; (EXTEND-SLOT extend n) - Returns the nth slot of an extend. +;;; (EXTEND? object) - Returns T if object is an extend, () otherwise. + +(DEFMACRO EXTEND (&REST X) ; HUNK args go in a funny order: 1, 2, ..., N-1, 0 + `(HUNK ,@(APPEND (CDR X) (NCONS (CAR X))))) + +(DEFMACRO EXTEND-SLOT (OBJ N) `(CXR ,N ,OBJ)) + +(DEFMACRO EXTEND? (X) `(HUNKP ,X)) ; Macro for compilation of this file +(DEFUN EXTEND? (X) (HUNKP X)) ; Also define it for use at runtime + +;;; (DEF-DATATYPE type pnget-fn evhook-fn slot1 slot2 ...) +;;; Defines an extended datatype with the following fields: +;;; type -- The name of the datatype. What TYPEP should return. +;;; pnget-fn -- A function of one arg (the object) which will compute +;;; the printname of each newly-created object. The pname +;;; is cached in the object for faster access. +;;; evhook-fn -- A function of two args (the object and the form) which +;;; defines how a form whose car evals to this object should +;;; be evaluated. +;;; aphook-fn -- A function of two args (the object and the evaluated +;;; argument set) which says how to apply the object. +;;; slot1,... -- Additional named slots can be created with each datatype +;;; and data accessors will be defined called type-slotname +;;; eg, a FOO type with slots BAR and BAZ would create access +;;; functions called FOO-BAR and FOO-BAZ. +;;; In addition, a type predicate by the name of type with a "?" added on +;;; the end is created. eg, a FOO type would get a FOO? predicate. + +(DEFMACRO DEF-DATATYPE (TYPE PNGET-FN EVHOOK-FN APHOOK-FN . SLOTS) + `(PROGN 'COMPILE + (DEF-DATATYPE-AUX (,TYPE -CREATE) ,SLOTS + (LET ((OBJECT + (EXTEND ',TYPE () #',EVHOOK-FN #',APHOOK-FN ,@SLOTS))) + (SETF (EXTEND-SLOT OBJECT 1.) (,PNGET-FN OBJECT)) + OBJECT)) + (DEF-DATATYPE-AUX (,TYPE ?) (X) + (AND (EXTEND? X) (EQ (EXTEND-SLOT X 0.) ',TYPE))) + ,@ (DO ((I 4. (1+ I)) (S SLOTS (CDR S)) (L ())) + ((NULL S) (NREVERSE L)) + (PUSH `(DEF-DATATYPE-AUX (,TYPE - ,(CAR S)) (X) + (EXTEND-SLOT X ,I)) + L)) + ', TYPE)) + +;;; Generic Extractor Functions +;;; These slots must be the same for all extended types to ensure fast +;;; access to the slot contents during evaluation, printing, etc. + +(DEFMACRO MU-TYPEP (X) `(EXTEND-SLOT ,X 0.)) ; Gets the Type of an Extend +(DEFMACRO MU-PNGET (X) `(EXTEND-SLOT ,X 1.)) ; Gets the PName of an Extend +(DEFMACRO MU-EVHOOK (X) `(EXTEND-SLOT ,X 2.)) ; Gets the EvHook of an Extend +(DEFMACRO MU-APHOOK (X) `(EXTEND-SLOT ,X 3.)) ; Gets the ApHook of an Extend + +(DEFMACRO DEF-DATATYPE-AUX (NAME-SPECS . DEF) ; Helper for DEF-DATATYPE + `(DEFUN ,(IMPLODE (MAPCAN #'EXPLODEN NAME-SPECS)) . ,DEF)) + + +;;;; Definitional Operators + +;;; (DEFINE (name . bvl) . body) +;;; Defines a ULisp micro-subr and puts the mu-subr-pointer in name's +;;; global value cell. + +(DEFMACRO DEFINE ((NAME . BVL) . BODY) + `(PROGN 'COMPILE + ,(COND ((AND BVL (ATOM BVL)) ; Arbitrary arity + `(DEFUN (,NAME MU-SUBR) ,BVL + ((LAMBDA (,BVL) . ,BODY) + (COND ((NOT (ZEROP ,BVL)) (LISTIFY ,BVL)) + (T ()))))) + (T ; Fixed arity + `(DEFUN (,NAME MU-SUBR) ,BVL . ,BODY))) + (MU-SET ',NAME (SUBR-CREATE (GET ',NAME 'MU-SUBR) ',NAME)) + ',NAME)) + +;;; (DEF-SPECFORM name (arg) body) +;;; Defines a ULisp special form and puts the special-form interpreter +;;; in name's global value cell. + +(DEFMACRO DEF-SPECFORM (NAME BVL . BODY) + `(PROGN 'COMPILE + (DEFUN (,NAME SPECIAL-FORM-INTERPRETER) ,BVL . ,BODY) + (MU-SET ',NAME (SPECIAL-FORM-CREATE + ',NAME + (GET ',NAME 'SPECIAL-FORM-INTERPRETER))) + ',NAME)) + +;;; (EQUIVALENCE Maclisp-name1 Maclisp-name2) +;;; Gives the the Maclisp functionality of Maclisp-name2 to Maclisp-name1. + +(DEFMACRO EQUIVALENCE (FUNCTION-NAME1 FUNCTION-NAME2) + `(DEFPROP ,FUNCTION-NAME1 ,FUNCTION-NAME2 EXPR)) + +;;; (IMPORT ULisp-Name [ Maclisp-Name ]) +;;; Gives the ULisp functionality of Maclisp-Name to ULisp-Name +;;; If Maclisp-Name is omitted, it is assumed to be the same as ULisp-Name. + +(DEFMACRO IMPORT (FUNCTION-NAME &OPTIONAL (SOURCE FUNCTION-NAME)) + `(MU-SET ',FUNCTION-NAME (SUBR-CREATE ',SOURCE ',FUNCTION-NAME))) + +;;; (MU-IMPORT ULisp-Name1 ULisp-Name2) +;;; Gives the ULisp functionality of ULisp-Name2 to ULisp-Name1. + +(DEFMACRO MU-IMPORT (FUNCTION-NAME1 FUNCTION-NAME2) + `(MU-SET ',FUNCTION-NAME1 (MU-EVSYM ',FUNCTION-NAME2))) + +;;; (DECLARE-TOPLEVEL-FLAG name value) +;;; Defines a flag that needs to be rebound every time there is a breakpoint. + +(DEFMACRO DECLARE-TOPLEVEL-FLAG (NAME VAL) + `(PROGN 'COMPILE + (DECLARE (SPECIAL ,NAME)) ; Declare var special + (PUSH ',NAME *TOPLEVEL-FLAGS*) ; Add var to flagvar list + (PUSH ',VAL *TOPLEVEL-VALUES*))) ; Add val to flagval list + +(DEFMACRO BIND-TOPLEVEL-FLAGS (&REST FORM) ; Primitive for doing the binding + `(PROGV *TOPLEVEL-FLAGS* *TOPLEVEL-VALUES* ,@FORM)) + +;;; (DEF-EVHOOK dtp fun) +;;; Names the function, fun, which eval should call when it gets an +;;; argument of type dtp to evaluate. + +(DEFMACRO DEF-EVHOOK (TYPE HOOK) `(DEFPROP ,TYPE ,HOOK MU-EVHOOK)) + + +;;;; Primary Datatype Definitions + +(DEF-DATATYPE CLOSURE ; Closure: closed procedure + MU-CLOSURE-PNGEN ; prints as # + MU-DEFAULT-EVHOOK ; evaluates args normally + MU-CLOSURE-APHOOK ; applies closures + DEFINITION ; associated procedural definition + ENVIRONMENT) ; associated environment + +(DEF-DATATYPE PROCEDURE ; Procedure: open procedure + MU-PROCEDURE-PNGEN ; prints as # + MU-DEFAULT-EVHOOK ; evaluates args normally + MU-PROCEDURE-APHOOK ; applies open procedures + DEFINITION) ; associated procedural definition + +(DEF-DATATYPE SPECIAL-FORM ; Special forms: cond, quote, setq,... + SPECIAL-FORM-NAME ; prints as # + MU-SPECFORM-EVHOOK ; evaluates body magically + () ; special forms may not be applied + NAME ; name slot + DEFINITION) ; definition slot + +(DEF-DATATYPE SUBR ; Subr: compiled definitions + SUBR-NAME ; prints as # + MU-DEFAULT-EVHOOK ; evaluates args normally + MU-SUBR-APHOOK ; applies subrs + POINTER ; a real subr pointer + NAME) ; the ULisp name of the SUBR + +; ------------------------------ Eval Support ------------------------------ + +(DEFUN MU-DEFAULT-EVHOOK (FN BODY) ; Evals a normal functional form + (MU-APPLY FN (MAPCAR #'MU-EVAL (CDR BODY)))) + +(DEFUN MU-SPECFORM-EVHOOK (FN BODY) ; Evals a special form + (FUNCALL (SPECIAL-FORM-DEFINITION FN) BODY)) + +; --------------------------- Apply Support --------------------------- + +(DEFUN MU-SUBR-APHOOK (FN ARG-LIST) ; Applies a compiled procedure + (LEXPR-FUNCALL (SUBR-POINTER FN) ARG-LIST)) + +(DEFUN MU-PROCEDURE-APHOOK (FN ARG-LIST) ; Applies an open procedure + (LET* (((PROCEDURE-ARGS . PROCEDURE-BODY) + (PROCEDURE-DEFINITION FN)) + (*ENV* (MU-BIND-ARGS PROCEDURE-ARGS ARG-LIST *ENV*))) + (MU-PROGN PROCEDURE-BODY))) + +(DEFUN MU-CLOSURE-APHOOK (FN ARG-LIST) ; Applies a closed procedure + (LET* (((CLOSURE-ARGS . CLOSURE-BODY) (CLOSURE-DEFINITION FN)) + (*ENV* (MU-BIND-ARGS CLOSURE-ARGS + ARG-LIST + (CLOSURE-ENVIRONMENT FN)))) + (MU-PROGN CLOSURE-BODY))) + +; --------------------------- Print Support --------------------------- + +(DEFUN MU-PROCEDURE-PNGEN (X) ; # + (CONS 'LAMBDA (PROCEDURE-DEFINITION X))) + +(DEFUN MU-CLOSURE-PNGEN (X) ; # + (CONS 'LAMBDA (CLOSURE-DEFINITION X))) + +;;;; Binding + +;;; (MU-BIND-ARG x y env) Binds x to y in an environment, env. Returns the new +;;; environment without altering the environment received as its arg. + +(DEFUN MU-BIND-ARG (X Y ENV) (CONS (CONS X Y) ENV)) + +;;; (MU-BIND-ARGS f a env) If f is a non-() symbol, binds all args to f +;;; by calling MU-BIND-ARG. Else, binds each element of f to corresponding +;;; element of a, returning result. Completely destroys the list structure +;;; in a. Does not side-effect on env. + +(DEFUN MU-BIND-ARGS (FORMALS ACTUALS ENV) + (COND ((AND (PAIRP FORMALS) + (NOT (= (LENGTH FORMALS) (LENGTH ACTUALS)))) + (MU-ERROR "Wrong number of args" (LIST FORMALS ACTUALS))) + ((NULL FORMALS) + (IF ACTUALS + (MU-ERROR "Wrong number of args" (LIST FORMALS ACTUALS)) + ENV)) + ((ATOM FORMALS) ; An n-ary function + (MU-BIND-ARG FORMALS ACTUALS ENV)) + (T + (DO ((F FORMALS (CDR F)) + (A ACTUALS (CDR A))) + ((NULL F) ACTUALS) + (RPLACA A (CONS (CAR F) (CAR A)));Recycle dead list structure + (COND ((NULL (CDR A)) ;Attach given environment + (RPLACD A ENV))))))) ; to recycled structure + +;;; (MU-SET var val) +;;; Will set VAR to VAL in the current evaluation context + +(DEFUN MU-SET (VAR VAL) + (MU-CHECK-ARGS 'SYMBOLP VAR) + (IF (NOT VAR) (MU-ERROR "Attempt to SETQ ()?" ())) + (LET ((VALUE-CELL (OR (ASSQ VAR *ENV*) + (GET VAR 'MU-GLOBAL-VALUE-CELL)))) + (COND ((NOT VALUE-CELL) + (PUTPROP VAR (CONS VAR VAL) 'MU-GLOBAL-VALUE-CELL)) + (T (RPLACD VALUE-CELL VAL))))) + +;;; (MU-EVSYM var) +;;; Takes an argument of a variable whose value is to be looked up. +;;; Returns the value of that variable. (Errs out if unbound) + +(DEFUN MU-EVSYM (SYM) + (IF (NULL SYM) () ; NIL is always () + (CDR (OR (ASSQ SYM *ENV*) + (GET SYM 'MU-GLOBAL-VALUE-CELL) + (MU-ERROR "Unbound Variable" SYM))))) + +;;; (MU-BOUNDP var) +;;; Returns T if var is bound in the current environment, else () + +(DEFUN MU-BOUNDP (SYM) + (MU-CHECK-ARGS #'(LAMBDA (X) (AND X (SYMBOLP X))) SYM) + (IF (OR (ASSQ SYM *ENV*) (GET SYM 'MU-GLOBAL-VALUE-CELL)) T)) + + +;;;; The MICRO Evaluator + +;;; (MU-EVAL form) +;;; The type of the object determines how it evaluates. + +(DEFUN MU-EVAL (X) + (BIND-EVALUATION-ENVIRONMENT X ; Tell it what is getting bound + (FUNCALL (OR (GET (TYPEP X) 'MU-EVHOOK) + #'(LAMBDA (X) X)) ; Things without handlers self-eval + X))) + +(DEF-EVHOOK SYMBOL MU-EVSYM) +(DEF-EVHOOK LIST MU-EVLIST) + +;;; (MU-EVLIST body) +;;; Evaluates the CAR of the form. If an extend, calls any associated +;;; evaluation handler. Else, errs out. + +(DEFUN MU-EVLIST (BODY) + (LET ((FN (MU-EVAL (CAR BODY)))) + (COND ((NOT (EXTEND? FN)) + (MU-ERROR "Invalid functional type." FN))) + (FUNCALL (OR (MU-EVHOOK FN) + (MU-ERROR "Invalid functional type." FN)) + FN BODY))) + +;;; (MU-APPLY fn arg-list) +;;; Applies fn to arg-list. fn must be a SUBR, PROCEDURE, CLOSURE, or +;;; TRACED object. Other objects are not applicable. + +(DEFUN MU-APPLY (FN ARG-LIST) + (FUNCALL (OR (MU-APHOOK FN) + (MU-ERROR "Can't APPLY this object" FN)) + FN ARG-LIST)) + +;;; (MU-APPLICABLE? obj) returns T if fn is an applicable object + +(DEFUN MU-APPLICABLE? (OBJ) + (AND (EXTEND? OBJ) (MU-APHOOK OBJ) T)) + +;;; (MU-CALL name arg1 arg2 ...) +;;; name is the name of a mu-subr to be called. arg1, arg2, etc. are the +;;; arguments to be supplied to that mu-subr. + +(DEFMACRO MU-CALL (FN &REST ARGS) + `(FUNCALL (GET ',FN 'MU-SUBR) ,@ARGS)) + +;;; (MU-PROGN L) maps MU-EVAL across L returning the last form eval'd. + +(DEFUN MU-PROGN (L) + (DO () + ((NULL (CDR L))) + (MU-EVAL (POP L))) + (MU-EVAL (CAR L))) + +;;;; Special Forms + +;;; (QUOTE obj) returns obj literally with no evaluation. + +(DEF-SPECFORM QUOTE (FORM) (CADR FORM)) + +;;; (SETQ var1 val1 var2 val2 ...) + +(DEF-SPECFORM SETQ (FORM) + (POP FORM) ; Ignore (CAR FORM) + (DO ((VAR) (VAL)) + ((NULL FORM) VAL) ; Return last val ... + (POP FORM VAR) + (SETQ VAL (MU-EVAL (POP FORM))) + (MU-SET VAR VAL))) + +;;; (DEFUN name bvl . body) +;;; Same as (SETQ name (LAMBDA bvl . body)) + +(DEF-SPECFORM DEFUN (FORM) + (LET (((NAME . LAMBDA-TAIL) (CDR FORM))) + (MU-SET NAME (MU-PROCEDURE LAMBDA-TAIL)) + NAME)) + +;;; (MU-PROCEDURE lambda-tail) +;;; Accepts a lambda-tail as an argument and creates either an open or +;;; closed procedure depending on the setting of *LEX* + +(DEFUN MU-PROCEDURE (LAMBDA-SPEC) + (COND (*LEX* (CLOSURE-CREATE LAMBDA-SPEC *ENV*)) + (T (PROCEDURE-CREATE LAMBDA-SPEC)))) + +;;; (LAMBDA name bvl . body) +;;; Evaluates to a procedure. + +(DEF-SPECFORM LAMBDA (FORM) + (MU-PROCEDURE (CDR FORM))) + +;;; (PROGN ...) +;;; +;;; Evaluates , , ... returning the value of the last +;;; form evaluated. + +(DEF-SPECFORM PROGN (FORM) + (MU-PROGN (CDR FORM))) + +;;; (COND (pred1 form1-1 form1-2 ...) +;;; (pred2 form2-1 form2-2 ...) ...) +;;; +;;; Evaluates pred1, pred2, ... in sequence until some predK returns +;;; a non-() value. Then evaluates formK-1, formK-2, ... in sequence, +;;; returning the value of the last form in that list evaluated or if there +;;; are no forms following a predK that evaluates to a non-() value, +;;; then that non-() value is returned as the value of the cond. +;;; +;;; If no pred returns non-(), then () is returned by the cond. + +(DEF-SPECFORM COND (CLAUSES) + (POP CLAUSES) ; (CAR CLAUSES) isn't a clause! + (DO () ((NULL CLAUSES)) + (COND ((ATOM (CAR CLAUSES)) + (MU-ERROR "Atomic COND clause" (CAR CLAUSES))) + ((MU-EVAL (CAAR CLAUSES)) + (RETURN T))) + (POP CLAUSES)) + (MU-PROGN (CDAR CLAUSES))) + +;;; (LET vars . body) + +(DEF-SPECFORM LET (FORM) + (LET (((VARS . BODY) (CDR FORM))) + (LET ((*ENV* (DO ((L VARS (CDR L)) + (BINDINGS *ENV*)) + ((NULL L) BINDINGS) + (CASEQ (TYPEP (CAR L)) + ((SYMBOL) (PUSH (NCONS (CAR L)) BINDINGS)) + ((LIST) (PUSH (CONS (CAAR L) + (MU-EVAL (CADAR L))) + BINDINGS)) + (T + (MU-ERROR "Illegal syntax in LET varlist" + VARS)))))) + (MU-PROGN BODY)))) + +;;; (IF condition consequent . alternative-implicit-progn ) + +(DEF-SPECFORM IF (FORM) + (LET (((CONDITION CONSEQUENT . ALTERNATIVE-LIST) (CDR FORM))) + (COND ((MU-EVAL CONDITION) + (MU-EVAL CONSEQUENT)) + (T + (MU-PROGN ALTERNATIVE-LIST))))) + +;;; (UNTIL condition . body) + +(DEF-SPECFORM UNTIL (FORM) + (LET (((CONDITION . BODY) (CDR FORM))) + (DO ((RV (MU-EVAL CONDITION) + (MU-EVAL CONDITION))) + (RV RV) + (MAPC #'MU-EVAL BODY)))) + +;;; (WHILE condition . body) + +(DEF-SPECFORM WHILE (FORM) + (LET (((CONDITION . BODY) (CDR FORM))) + (DO ((RV (MU-EVAL CONDITION) + (MU-EVAL CONDITION))) + ((NOT RV) RV) + (MAPC #'MU-EVAL BODY)))) + +;;; (AND form1 form2 ...) +;;; +;;; Evaluates form1, form2, ... until a form returns (), in which case +;;; it returns (). If all forms return non-(), the value of the last form +;;; is returned. If there were no forms (degenerate or identity case), T is +;;; returned. + +(DEF-SPECFORM AND (FORM) + (DO ((BODY (CDR FORM) (CDR BODY)) (VAL T)) + ((NULL BODY) VAL) + (IF (NULL (SETQ VAL (MU-EVAL (CAR BODY)))) + (RETURN ())))) + +;;; (OR form1 form2 ...) +;;; +;;; Evaluates form1, form2, ... until a form returns non-(), in which case +;;; it returns that value. If all forms return (), then () is returned. +;;; If no args are given, () is returned. + +(DEF-SPECFORM OR (FORM) + (DO ((BODY (CDR FORM) (CDR BODY)) (VAL ())) + ((NULL BODY) ()) + (IF (SETQ VAL (MU-EVAL (CAR BODY))) + (RETURN VAL)))) + + +;;; (DO vars (exit-test . exit-body) . body) + +(DEF-SPECFORM DO (FORM) + (LET* (((VARS (EXIT-TEST . EXIT-BODY) . BODY) (CDR FORM)) + (LOOP-SETUPS ()) + (*ENV* (DO ((V VARS (CDR V)) + (E *ENV*) + (ENTRY)) + ((NULL V) E) + (COND ((SYMBOLP (SETQ ENTRY (CAR V))) + (PUSH (NCONS ENTRY) E)) + (T + (PUSH (CONS (CAR ENTRY) + (MU-EVAL (CADR ENTRY))) E) + (IF (CDDR ENTRY) + (PUSH (CONS (CAR ENTRY) (CADDR ENTRY)) + LOOP-SETUPS))))))) + (SETQ LOOP-SETUPS (NREVERSE LOOP-SETUPS)) + (DO () + ((MU-EVAL EXIT-TEST) (MU-PROGN EXIT-BODY)) + (MU-PROGN BODY) + (MU-PARALLEL-SETQ LOOP-SETUPS)))) + +;;; Helping function for the DO evaluator +;;; (MU-PARALLEL-SETQ '((var1 . exp1) (var2 . exp2) ... (varN . expN))) + +(DEFUN MU-PARALLEL-SETQ (ALIST) + (COND ((NULL ALIST) ()) + (T (LET ((VAR (CAAR ALIST)) (VAL (MU-EVAL (CDAR ALIST)))) + (MU-PARALLEL-SETQ (CDR ALIST)) + (MU-SET VAR VAL))))) + +;;; (CASEQ key clause1 ...) + +(DEF-SPECFORM CASEQ (FORM) + (LET (((KEY . CLAUSES) (CDR FORM)) (TEST)) + (SETQ KEY (MU-EVAL KEY)) + (SETQ TEST + (CASEQ (TYPEP KEY) + ((SYMBOL) #'MEMQ) + ((FIXNUM FLONUM BIGNUM) #'MEM=) + (T (MU-ERROR "Bad key to CASEQ" KEY)))) + (DO ((C CLAUSES (CDR C))) + ((NULL C) ()) ; Return () if fall off end + (COND ((OR (EQ (CAAR C) 'T) + (FUNCALL TEST KEY (CAAR C))) + (RETURN (MU-PROGN (CDAR C)))))))) + +;;; (MEM= key list) returns T if key is in list + +(DEFUN MEM= (KEY L) + (DO ((L L (CDR L))) + ((NULL L) ()) + (IF (MU-CALL = KEY (CAR L)) + (RETURN T)))) + +;;;; I/O Support + +;;; (MU-OUTSTREAM-HANDLER self op data) - An SFA which takes all output +;;; fed to it and outputs it to any streams on *OUTSTREAMS*. + +(DEFUN MU-OUTSTREAM-HANDLER (SELF OP DATA) + (CASEQ OP + ((WHICH-OPERATIONS) '(TYO CHARPOS LINEL)) + ((TYO) + (IF (NOT (MINUSP DATA)) (TYO DATA *OUTSTREAMS*))) + ((CHARPOS LINEL) + (FUNCALL OP (CAR *OUTSTREAMS*))) + (T ; Bad error + (ERROR "ULisp Bug: Please report this. Illegal output SFA operation." + `(SFA-CALL ,SELF ,OP ,DATA))))) + +;;; (MU-READ [stream] [eofval]) - The ULisp Reader + +(DEFUN MU-READ N + (LET ((IBASE *IBASE*)) + (COND ((= N 0) (READ)) + ((= N 1) (READ (ARG 1))) + (T (READ (ARG 1) (ARG 2)))))) + + +;;;; Internal Printer Routines + +;;; (MU-PRIN1 obj stream) - The ULisp system printer (with slashifying) +;;; (MU-PRINC obj stream) - The ULisp system printer (without slashifying) +;;; (MU-PRIN obj stream) - Internal entry point to the printer. Expects +;;; *SLASHIFY* and *PRINLEVEL-COUNT* to have been set up correctly. +;;; (MU-PRIN\ATOMIC obj stream) - Internal entry to printer of atomic +;;; and extended objects. + +(DEFUN MU-PRIN1 (OBJECT STREAM) + (LET ((*SLASHIFY* T) (*PRINLEVEL-COUNT* 1.)) + (MU-PRIN OBJECT STREAM))) + +(DEFUN MU-PRINC (OBJECT STREAM) + (LET ((*SLASHIFY* ()) (*PRINLEVEL-COUNT* 1.)) + (MU-PRIN OBJECT STREAM))) + +(DEFUN MU-PRIN (OBJECT STREAM) + (LET ((*PRINLEVEL-COUNT* (1+ *PRINLEVEL-COUNT*))) + (COND ((OR (ATOM OBJECT) (EXTEND? OBJECT)) + (MU-PRIN\ATOMIC OBJECT STREAM)) + ((QUOTED? OBJECT) + (TYO #/' STREAM) + (MU-PRIN (CADR OBJECT) STREAM)) + ((AND *PRINLEVEL* + (> *PRINLEVEL-COUNT* *PRINLEVEL*)) + (PRINC "(...)" STREAM) + OBJECT) + (T + (TYO #/( STREAM) + (DO ((L OBJECT (CDR L)) + (C 1. (1+ C)) + (FLAG () T)) + ((OR (ATOM L) (EXTEND? L)) + (COND (L (PRINC " . " STREAM) + (MU-PRIN\ATOMIC L STREAM))) + (TYO #/) STREAM) + OBJECT) + (COND ((AND *PRINLENGTH* (> C *PRINLENGTH*)) + (PRINC " ...)" STREAM) + (RETURN OBJECT))) + (COND (FLAG (TYO #\SPACE STREAM))) + (MU-PRIN (CAR L) STREAM)))))) + +(DEFUN MU-PRIN\ATOMIC (OBJECT STREAM) + (COND ((EXTEND? OBJECT) + (PRINC "#<" STREAM) + (MU-PRIN (MU-TYPEP OBJECT) STREAM) + (TYO #\SPACE STREAM) + (MU-PRIN (MU-PNGET OBJECT) STREAM) + (PRINC ">" STREAM)) + ((NUMBERP OBJECT) + (LET ((BASE *OBASE*) (*NOPOINT T)) + (PRIN1 OBJECT STREAM))) + ((NULL OBJECT) + (PRINC "()" STREAM)) + ((SYMBOLP OBJECT) + (COND (*SLASHIFY* (PRIN1 OBJECT STREAM)) + (T (PRINC OBJECT STREAM)))) + (T + (PRINC "#" STREAM))) + OBJECT) + +;;;; Psuedo-I/O Functions + +;;; (MU-FLATSIZE
) - A ULisp version of Maclisp's FLATSIZE. +;;; (MU-FLATSIZE-HANDLER self op data) - An SFA helper for MU-FLATSIZE. + +(DEFUN MU-FLATSIZE (X PRINTER) + (LET ((*FLATSIZE* 0.)) + (FUNCALL PRINTER X *FLATSIZE-SFA*) + *FLATSIZE*)) + +(DEFUN MU-FLATSIZE-HANDLER (SELF OP DATA) + (CASEQ OP + (WHICH-OPERATIONS '(TYO)) + (TYO (COND ((NOT (MINUSP DATA)) + (SETQ *FLATSIZE* (1+ *FLATSIZE*))))) + (T (ERROR "UnSupported Operation" (LIST 'SFA-CALL SELF OP DATA))))) + +;;; (MU-EXPLODE object printer) - A ULisp version of Maclisp's EXPLODE. +;;; (MU-EXPLODEN object printer) - A ULisp version of Maclisp's EXPLODEN. +;;; (MU-EXPLODE-HANDLER self op data) - An SFA helper for MU-EXPLODEN. + +(DEFUN MU-EXPLODE (OBJECT PRINTER) + (MAP #'(LAMBDA (X) (RPLACA X (ASCII (CAR X)))) + (MU-EXPLODEN OBJECT PRINTER))) + +(DEFUN MU-EXPLODEN (OBJECT PRINTER) + (LET ((*EXPLODED* ())) + (FUNCALL PRINTER OBJECT *EXPLODE-SFA*) + (NREVERSE *EXPLODED*))) + +(DEFUN MU-EXPLODE-HANDLER (SELF OP DATA) + (CASEQ OP + (WHICH-OPERATIONS '(TYO)) + (TYO (COND ((NOT (MINUSP DATA)) (PUSH DATA *EXPLODED*)))) + (T (ERROR "UnSupported Operation" (LIST 'SFA-CALL SELF OP DATA))))) + +;;; (MU-IMPLODE char-list) - A ULisp version of Maclisp's READLIST. +;;; (MU-IMPLODE-HANDLER self op data) - An SFA helper for MU-IMPLODE. + +(DEFUN MU-IMPLODE (CHAR-LIST) + (LET ((*IMPLODABLE* CHAR-LIST)) + (MU-READ *IMPLODE-SFA*))) + +(DEFUN MU-IMPLODE-HANDLER (SELF OP DATA) + (CASEQ OP + (WHICH-OPERATIONS '(UNTYI TYI)) + (UNTYI (PUSH DATA *IMPLODABLE*)) + (TYI (COND ((NULL *IMPLODABLE*) ; Out of chars? + (SETQ *IMPLODABLE* T) ; Set flag to avoid infinite loop + #\SPACE) ; Output a trailing break char + ((ATOM *IMPLODABLE*) ; Check for infinite loop + (MU-ERROR "IMPLODE ran out of characters" ())) + (T + (LET ((CHAR (POP *IMPLODABLE*))) + (COND ((SYMBOLP CHAR) (GETCHARN CHAR 1.)) + (T CHAR)))))) + (T (ERROR "UnSupported Operation" (LIST 'SFA-CALL SELF OP DATA))))) + +;;;; The Read-Eval-Print-Loop + +(DEFUN MU-READ-EVAL-PRINT-LOOP () + (DO () + (()) ; Loop indefinitely + (TERPRI *OUTSTREAM*) ; Get a fresh line + (BIND-TOPLEVEL-FLAGS + (ERRSET (*CATCH 'MU-ERROR-RETURN ; Trap errors + (LET* ((*ULISP* T) ; Flag for error handler + (FORM (MU-READ))) ; Read a form + (TERPRI *OUTSTREAM*) ; Acknowledge reading form + (IF (EQ FORM '/P) ; If P, recover from break + (IF (PLUSP *BREAK-LEVEL*) + (MU-BREAK-RECOVER ()) + (MU-FORMAT "~%;At toplevel already.") + (*THROW 'MU-ERROR-RETURN ()))) + (LET ((RESULT (MU-EVAL FORM))) + (MU-SET '%IN FORM) ; Set %IN to form we read + (MU-SET '%OUT RESULT) ; %OUT <- result + (TERPRI *OUTSTREAM*) ; Get a fresh line + (MU-PRIN1 RESULT *OUTSTREAM*); Type result + (TERPRI *OUTSTREAM*)))) ; end w/ terpri + T)))) ; Display error messages + +(DEFUN MU-BREAK-LOOP (MESSAGE) + (LET ((*BREAK-LEVEL* (1+ *BREAK-LEVEL*)) + (^Q ())) ; If reading from file, stop! + (MU-FORMAT "~%;Bkpt ") + (MU-PRINC MESSAGE *OUTSTREAM*) + (MU-FORMAT "~%;Level ~D" *BREAK-LEVEL*) + (PROG1 (*CATCH 'MU-BREAK-RETURN (MU-READ-EVAL-PRINT-LOOP)) + (MU-FORMAT ";Returning from Bkpt Level ~D~%" + *BREAK-LEVEL*)))) + +(DEFUN MU-BREAK-RECOVER (VALUE) + (COND ((ZEROP *BREAK-LEVEL*) + (MU-ERROR "Not inside a break loop" VALUE)) + (T + (*THROW 'MU-BREAK-RETURN VALUE)))) + +;;; MU-ERROR +;;; +;;; PRINC the error MESSAGE on the console on a fresh line, followed by +;;; the associated DATA, also on a fresh line. If there is backtrace +;;; information, show that as well. + +(DEFUN MU-ERROR (MESSAGE DATA) + (LET ((*ERRFRAME* (ERROR-FRAME MESSAGE + DATA + *ERRFRAME* ; Previous error frame + *BACKLIST* ; Environment info + ))) + (COND ((NOT *ULISP*) (ERROR MESSAGE DATA 'FAIL-ACT)) + (T + (MU-FORMAT "~%;") + (MU-PRINC MESSAGE *OUTSTREAM*) + (MU-FORMAT "~%;") + (MU-PRIN1 DATA *OUTSTREAM*) + (TERPRI *OUTSTREAM*) + (COND (*DEBUG* (MU-BREAK-LOOP MESSAGE))) + (*THROW 'MU-ERROR-RETURN ()))))) ; Mu-Errors are not recoverable + + +;;;; Condition Handlers + +; ------------------------- TTY Interrupt Handlers ------------------------- + +;;; ^B Handler -- Pauses in the middle of evaluation. + +(DEFUN MU-^B-HANDLER (() ()) ;Ignore args + (NOINTERRUPT ()) ; Re-Enable Interrupts + (COND (*ULISP* (MU-BREAK-LOOP "^B")) + (T (*BREAK T "^B")))) + +;;; ^E Handler -- Resumes the editor + +(DEFUN MU-LEDIT (&OPTIONAL (JNAME NIL JNAME?)) + (DO ((FILE (PROBEF *EDITOR-COMM-FILE*) ; Delete lost comm files + (PROBEF *EDITOR-COMM-FILE*))) + ((NULL FILE)) + (DELETEF FILE)) + (NOINTERRUPT ()) ; Re-Enable interrupts + (COND (JNAME? (SETQ *EDITOR-JOB-NAME* JNAME))) + (COND ((NOT *EDITOR-JOB-NAME*) ; Read editor name if needed + (MU-FORMAT "~%Editor Name: ") + (SETQ *EDITOR-JOB-NAME* (READLINE)))) + (COND ((STATUS FEATURE ITS) ; Jump to editor + (VALRET (MAKNAM (NCONC (EXPLODEN *EDITOR-JOB-NAME*) '(#^H))))) + (T + (VALRET (MAKNAM (NCONC (EXPLODEN "CONT ") + (EXPLODEN *EDITOR-JOB-NAME*) + '(#^M #^J)))))) + (LET ((COMM-FILE (PROBEF *EDITOR-COMM-FILE*))) + (COND ((NOT COMM-FILE) + (MU-FORMAT "~%;Back to Lisp. No updates to load.~%") + ()) + (T + (MU-CALL LOAD COMM-FILE T) + (DELETEF COMM-FILE) + T)))) + +(DEFUN MU-^E-HANDLER (() ()) (MU-LEDIT)) + +;;; ^X Handler -- Stops evaluation. Returns to last errset. + +(DEFUN MU-^X-HANDLER (STREAM ()) ;Ignore second arg + (NOINTERRUPT ()) ; Re-Enable Interrupts + (CLEAR-INPUT STREAM) + (COND (*ULISP* ; If in ULisp, + (IF (ZEROP *BREAK-LEVEL*) + (MU-FORMAT ";Quit at toplevel~%") + (MU-FORMAT ";Quit at break level ~D~%" *BREAK-LEVEL*)) + (*THROW 'MU-ERROR-RETURN ())) ; Return to last error handler + (T ; Else, + (ERROR 'QUIT)))) ; Just run an error quit + +; ----------------- Ctrl-Character Interrupts and Macros ----------------- + +(DO ((I #^A (1+ I))) ((> I #^Z)) ; Disable all tty interrupts + (SSTATUS TTYINT I ())) + +(SSTATUS TTYINT #^B #'MU-^B-HANDLER) ; ^B runs pause-type breakpoint +(SSTATUS TTYINT #^E #'MU-^E-HANDLER) ; ^E runs jump to editor job +(SSTATUS TTYINT #^G #^G) ; ^G runs the normal quit-to-toplevel +(SSTATUS TTYINT #^X #'MU-^X-HANDLER) ; ^X runs error-type quit +(SSTATUS TTYINT #^Z #^Z) ; ^Z runs normal return-to-superior-job + +; ---------------------------- Error Handlers ---------------------------- + +;;; Handler for GC Overflows -- Just blindly allocates new storage + +(DEFUN MU-GC-OVERFLOW-HANDLER (()) T) + +;;; Handler for ERRSETs + +(DEFUN MU-ERRSET-HANDLER (()) (*THROW 'MU-ERROR-RETURN ())) + +(DEFUN MU-MACLISP-ERROR-INTERPRETER (ARGS) + (DECLARE (SPECIAL ARGS)) ; For debugging + (LET (((MESSAGE () ERROR-TYPE) (CADDR (ERRFRAME NIL)))) + (COND (*ULISP* ; If in a ULISP environment + (MU-ERROR MESSAGE (BACKLIST-FORM *BACKLIST*))) + (T ; If in Maclisp, fake an error break + (FORMAT T "~%;~S ~A~%" ARGS MESSAGE) + (*BREAK T ERROR-TYPE))))) + +(DEFUN MU-PDL-BREAK (ARGS) + (COND (*ULISP* (MU-ERROR "Stack Overflow" (CONS 'STACK= ARGS))) + (T (FORMAT T "~%;~S Overflow~%" (CAR ARGS)) + (*BREAK T "PDL Overflow")))) + +;;; Error Handlers + +(SETQ ERRSET #'MU-ERRSET-HANDLER + GC-OVERFLOW #'MU-GC-OVERFLOW-HANDLER + PDL-OVERFLOW #'MU-PDL-BREAK + *RSET-TRAP () + FAIL-ACT #'MU-MACLISP-ERROR-INTERPRETER + GC-LOSSAGE #'MU-MACLISP-ERROR-INTERPRETER + IO-LOSSAGE #'MU-MACLISP-ERROR-INTERPRETER + UNBND-VRBL #'MU-MACLISP-ERROR-INTERPRETER + UNDF-FNCTN #'MU-MACLISP-ERROR-INTERPRETER + UNSEEN-GO-TAG #'MU-MACLISP-ERROR-INTERPRETER + WRNG-NO-ARGS #'MU-MACLISP-ERROR-INTERPRETER + WRNG-TYPE-ARG #'MU-MACLISP-ERROR-INTERPRETER + ) + + +;;;; Readmacro Characters + +(PROGN + + (DO ((I 0. (1+ I))) + ((= I #o200)) + (SSTATUS MACRO (PROGN I) NIL)) ; Turn off all readmacro properties + + (SSTATUS MACRO /' '+INTERNAL-/'-MACRO) + (SSTATUS MACRO /; '+INTERNAL-/;-MACRO SPLICING) + (SSTATUS MACRO /| '+INTERNAL-/|-MACRO) + + (SETSYNTAX '/, 'A '/,) + (SETSYNTAX '/# 'A '/#) + (SETSYNTAX '/` 'A '/`)) + +(DEFUN MU-/"-READMACRO () + (DO ((C (TYI) (TYI)) + (L () (CONS C L))) + ((= C #/") + (LET ((RESULT (MAKNAM (NREVERSE L)))) + (SET RESULT RESULT) ; for MacLISP debugging + (MU-SET RESULT RESULT) + RESULT)) + (IF (= C #//) (SETQ C (TYI))))) + +(SSTATUS MACRO /" #'MU-/"-READMACRO) + + +;;;; The MACRO Datatype + +;;; ------------------------------ Support ------------------------------ + +(DEF-DATATYPE MACRO ; Macro: code transformation procedure + MU-MACRO-PNGEN ; prints as # + MU-MACRO-EVHOOK ; evaluates body magically + () ; macros are not applicable + PROCEDURE) ; definition + +;;; (MU-MACRO-PNGEN obj) +;;; Allows macros to print as # where name is the printname +;;; of their associated procedures. + +(DEFUN MU-MACRO-PNGEN (X) + (MU-PNGET (MACRO-PROCEDURE X))) + +;;; (MU-PROCEDURE-PNGEN obj) + +;;; (MU-MACROEXPAND macro-obj body) +;;; Calls the procedure associated with macro-obj on body to acquire a +;;; ``macro expansion'' which it returns. + +(DEFUN MU-MACROEXPAND (FN BODY) + (MU-APPLY (MACRO-PROCEDURE FN) (NCONS BODY))) + +;;; (MU-MACRO-EVHOOK obj body) +;;; Calls the associated procedure of obj to get a macro expansion. Then +;;; evaluates the result of the expansion. + +(DEFUN MU-MACRO-EVHOOK (FN BODY) + (MU-EVAL (MU-MACROEXPAND FN BODY))) + +; --------------------------- User Operators --------------------------- + +;;; (MACRO name (arg) . body) Defines a macro. +;;; (MACROP obj) Returns T if obj is a macro, else () +;;; (MACROEXPAND form) If form is a list whose car is a symbol with +;;; the value of a macro object, expands the form +;;; one level and returns result, else returns arg. +;;; (MACROFY form) Accepts a function, makes a macro out of it. +;;; (DEMACROFY form) Undoes a (MACROFY form) + +(DEF-SPECFORM MACRO (FORM) + (LET (((NAME . LAMBDA-TAIL) (CDR FORM))) + (MU-SET NAME (MACRO-CREATE (MU-PROCEDURE LAMBDA-TAIL))) + NAME)) + +(IMPORT MACROP MACRO?) ; Import MACROP definition from MACRO? + +(DEFINE (MACROEXPAND FORM) + (COND ((AND (PAIRP FORM) ; Only macroexpand lists + (SYMBOLP (CAR FORM)) ; which start with a sym + (MU-BOUNDP (CAR FORM))) ; which is bound + (LET ((VAL (MU-EVAL (CAR FORM)))) ; Eval (CAR FORM) + (COND ((NOT (MACRO? VAL)) FORM) ; Fail if not macro + (T ; Else macroexpand + (MU-MACROEXPAND VAL FORM))))) + (T FORM))) + +(DEFINE (MACROFY PROC) + (MU-CHECK-ARGS #'(LAMBDA (X) + (OR (PROCEDURE? X) (CLOSURE? X) (SUBR? X))) + PROC) + (MACRO-CREATE PROC)) + +(DEFINE (DEMACROFY MACRO-OBJ) + (MU-CHECK-ARGS #'MACRO? MACRO-OBJ) + (MACRO-PROCEDURE MACRO-OBJ)) + + + +;;;; The TRACED Datatype + +;;; ------------------------------ Support ------------------------------ + +(DECLARE (SPECIAL ; Trace Module Compiler Declarations + *TRACE-LEVEL* ; The level that trace level is set to + )) + +(DEF-DATATYPE TRACED ; Traced: traced procedural definition + TRACED-NAME ; prints as # + MU-DEFAULT-EVHOOK ; evaluates args normally + MU-TRACED-APHOOK ; applies traced procedures + PROCEDURE ; associated procedural definition + NAME) ; name of fun at trace time + +(DECLARE-TOPLEVEL-FLAG *TRACE-LEVEL* 0.) + +(DEFUN MU-TRACED-APHOOK (FN ARG-LIST) ; Traced Procedure + (MU-TRACE-ENTRY-PRINT FN ARG-LIST) + (MU-TRACE-EXIT-PRINT FN + (LET ((*TRACE-LEVEL* (1+ *TRACE-LEVEL*))) + (MU-APPLY (TRACED-PROCEDURE FN) ARG-LIST)))) + +(DEFUN MU-TRACE-ENTRY-PRINT (FN ARG-LIST) + (MU-TRACE-ANNOUNCE "Enter " (TRACED-NAME FN) " " ARG-LIST)) + +(DEFUN MU-TRACE-EXIT-PRINT (FN RETURN-VALUE) + (MU-TRACE-ANNOUNCE "+- " (TRACED-NAME FN) " -> " RETURN-VALUE)) + +(DEFUN MU-TRACE-ANNOUNCE (MSG1 OPERATOR MSG2 DATA) + (TERPRI *OUTSTREAM*) + (DO ((I 0. (1+ I))) ((= I *TRACE-LEVEL*)) (PRINC "/| " *OUTSTREAM*)) + ( PRINC MSG1 *OUTSTREAM*) + (MU-PRIN1 OPERATOR *OUTSTREAM*) + ( PRINC MSG2 *OUTSTREAM*) + (MU-PRIN1 DATA *OUTSTREAM*) + DATA) + +;;; --------------------------- User Functions --------------------------- + +;;; (TRACEDP obj) Returns T if obj is TRACED. +;;; (*TRACE procedure name) Returns traced procedure if possible, else arg +;;; (*UNTRACE procedure) Returns source procedure if possible, else arg +;;; (TRACE fn1 fn2 ...) Traces fn1 fn2... args *not* evaluated +;;; (UNTRACE fn1 fn2 ...) Untraces fn1 fn2... args *not* evaluated + +(IMPORT TRACEDP TRACED?) ; Import TRACEDP definition from TRACED? + +(DEFINE (*TRACE DEF NAME) + (IF (OR (SUBR? DEF) (PROCEDURE? DEF) (CLOSURE? DEF)) ; If traceable, + (TRACED-CREATE DEF NAME) ; then trace it + (MU-ERROR "Can't trace this object" DEF))) ; else err out + +(DEFINE (*UNTRACE DEF) + (IF (TRACED? DEF) ; If traced, + (TRACED-PROCEDURE DEF) ; then untrace it + (MU-ERROR "Can't untrace this object" DEF))) ; else err out + +(DEF-SPECFORM TRACE (FORM) + (MAPC #'(LAMBDA (NAME) + (MU-CHECK-ARGS 'SYMBOLP NAME) + (MU-SET NAME + (MU-CALL *TRACE (MU-EVAL NAME) NAME))) + (CDR FORM))) + +(DEF-SPECFORM UNTRACE (FORM) + (MAPC #'(LAMBDA (NAME) + (MU-CHECK-ARGS 'SYMBOLP NAME) + (MU-SET NAME + (MU-CALL *UNTRACE (MU-EVAL NAME)))) + (CDR FORM))) + +;;;; The ARRAY Datatype + +; ------------------------------ Support ------------------------------ + +(DEF-DATATYPE ARRAY ; Array: randomly-accessible storage + MU-ARRAY-PNGEN + MU-DEFAULT-EVHOOK ; this datatype is not applicable + MU-ARRAY-APHOOK ; applies arrays + STORAGE) ; storage slot (for Maclisp array obj) + +(DEFUN MU-ARRAY-PNGEN (MU-ARRAY-OBJ) + (CDR (ARRAYDIMS (ARRAY-STORAGE MU-ARRAY-OBJ)))) + +(DEFUN MU-ARRAY-APHOOK (FN ARG-LIST) + (APPLY (ARRAY-STORAGE FN) ARG-LIST)) + +; --------------------------- User Functions --------------------------- + +;;; (MAKE-ARRAY dim1 dim2 ...) creates an array with the given dimensions +;;; (ARRAYP obj) returns T for obj being an array, else () +;;; (array dim1 dim2 ...) accesses an array +;;; (STORE (array dim1 dim2 ...) val) stores a val into array + +(DEFINE (MAKE-ARRAY . DIMS) + (ARRAY-CREATE (LEXPR-FUNCALL #'*ARRAY () 'T DIMS))) + +(IMPORT ARRAYP ARRAY?) + +(DEF-SPECFORM STORE (FORM) + (LET (((ARRAYREF EXPRESSION) (CDR FORM))) + (STORE (MU-EVAL ARRAYREF) (MU-EVAL EXPRESSION)))) + +; ------------------------------ Compatibility Functions from last term + +(DEFINE (ASET . FORM) + (LET (((VAL ARRAYOBJ . DIMS) FORM)) + (MU-CHECK-ARGS #'ARRAY? ARRAYOBJ) + (STORE (APPLY (ARRAY-STORAGE ARRAYOBJ) DIMS) VAL))) + +(DEFINE (AREF . BODY) + (LET (((ARRAYOBJ . DIMS) BODY)) + (MU-CHECK-ARGS #'ARRAY? ARRAYOBJ) + (APPLY (ARRAY-STORAGE ARRAYOBJ) DIMS))) + +(DEFINE (MAKE_ARRAY . TYPE-DOT-DIMS) + (IF (NOT (MEMQ (CAR TYPE-DOT-DIMS) '(FIXNUM FLONUM T ()))) + (IF (FIXP (CAR TYPE-DOT-DIMS)) + (MU-ERROR "Bad args to MAKE_ARRAY. Maybe you want MAKE-ARRAY." + TYPE-DOT-DIMS) + (MU-ERROR "Bad args to MAKE_ARRAY." TYPE-DOT-DIMS))) + (ARRAY-CREATE (LEXPR-FUNCALL #'*ARRAY () 'T + (COND ((FIXP (CADR TYPE-DOT-DIMS)) + (CDR TYPE-DOT-DIMS)) + ((AND (LIST? (CADR TYPE-DOT-DIMS)) + (NOT (CDDR TYPE-DOT-DIMS))) + (CADR TYPE-DOT-DIMS)) + (T + (MU-ERROR + "Bad arg(s) to MAKE_ARRAY" + TYPE-DOT-DIMS)))))) + + ; This should do a CDR next term when info about type is deleted from + ; the notes +(DEFINE (ARRAYDIMS ARRAYOBJ) + (MU-CHECK-ARGS #'ARRAY? ARRAYOBJ) + (APPEND (ARRAYDIMS (ARRAY-STORAGE ARRAYOBJ)) ())) ; Copy for safety + + +;;;; The Pretty-Printer + +;;; ------------------------------ Support ------------------------------ + +(DEFUN MU-PP\INDENT (X STREAM) + (TERPRI STREAM) + (DO I 0. (1+ I) (= I X) (TYO #\SPACE STREAM))) + +(DEFUN MU-PP\AUX (X STREAM) + (COND ((ATOM X) (MU-PRIN1 X STREAM)) + ((EXTEND? X) + (PRINC "#<" STREAM) + (PRINC (MU-TYPEP X) STREAM) + (TYO #\SPACE STREAM) + (MU-PP\AUX (MU-PNGET X) STREAM) + (PRINC ">" STREAM)) + ((QUOTED? X) + (TYO #/' STREAM) + (MU-PP\AUX (CADR X) STREAM)) + ((> (MU-FLATSIZE X 'MU-PRIN1) + (- (LINEL STREAM) (CHARPOS STREAM))) + (PRINC "(" STREAM) + (LET ((P (CHARPOS STREAM))) + (MU-PP\AUX (CAR X) STREAM) + (COND ((NOT (ATOM (CAR X))) + (MU-PP\INDENT (1- P) STREAM)))) + (DO ((L (CDR X) (CDR L)) + (FLAG () T) + (P (CHARPOS STREAM))) + ((OR (ATOM L) (EXTEND? L)) + (COND (L (PRINC " . " STREAM) + (MU-PRIN1 L STREAM))) ; Extends don't pretty print + (PRINC ")" STREAM)) ; here. Maybe they should... + (PRINC " " STREAM) + (AND FLAG (MU-PP\INDENT (1+ P) STREAM)) + (MU-PP\AUX (CAR L) STREAM))) + (T + (MU-PRIN1 X STREAM)))) + +;;; --------------------------- User Functions --------------------------- + +(DEFINE (PP X) ; Pretty-prints a form on the terminal + (TERPRI *OUTSTREAM*) + (MU-PP\AUX X *OUTSTREAM*) + (TERPRI *OUTSTREAM*) + '*) + +;;;; Evaluation Control + +;;; (BREAK pred msg) creates a breakpoint, typing out msg iff pred is non-() +;;; +;;; (ERROR message [data]) signals an error. Types message on console. +;;; +;;; (QUIT) stops execution of any program. Kills the lisp job. +;;; +;;; (EVAL obj) recursively invokes the evaluator on obj, returning result. +;;; (APPLY fn arg-list) applies fn to arg-list, returning the resulting value. +;;; fn must be type SUBR, PROCEDURE, CLOSURE or TRACED. +;;; (MAPCAR function l1 l2 ...) like Maclisp MAPCAR, but uses MU-APPLY. +;;; +;;; (CLOSURE proc) Takes an open procedure as an argument and returns its +;;; closure. If arg is a closure, just returns it. + +(DEFINE (BREAK CONDITION MESSAGE) + (IF CONDITION + (MU-BREAK-LOOP MESSAGE))) + +(DEFINE (ERROR . DATA) + (COND ((NULL (CDR DATA)) + (MU-ERROR "Error Signalled" (CAR DATA))) + (T + (MU-ERROR (CAR DATA) (CADR DATA))))) + +(DEFINE (QUIT) + (QUIT)) + +(DEFINE (EVAL X) + (LET ((*ENV* (IF *LEX* () *ENV*))) + (MU-EVAL X))) + +(DEFINE (APPLY FN ARG-LIST) + (MU-CHECK-ARGS 'EXTEND? FN) ; MU-APPLY expects an EXTEND as arg1 + (MU-APPLY FN (APPEND ARG-LIST ()))) ; Copy arglist! It's RPLAC'd later + +(IMPORT APPLICABLEP MU-APPLICABLE?) + +(DEFINE (MAPCAR . ARG-LIST) + (LET (((FN . L) ARG-LIST)) + (DECLARE (SPECIAL FN)) + (MU-CHECK-ARGS #'MU-APPLICABLE? FN) + (LEXPR-FUNCALL #'MAPCAR + #'(LAMBDA X + (DECLARE (SPECIAL FN)) + (MU-APPLY FN (LISTIFY X))) + L))) + +(DEFINE (CLOSURE X) + (COND ((PROCEDURE? X) (CLOSURE-CREATE (PROCEDURE-DEFINITION X) *ENV*)) + ((CLOSURE? X) X) + (T + (MU-ERROR "Arg must be a procedure or closure." X)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Compatibility with old notes + +(MU-IMPORT CLOSE-IT CLOSURE) ; CLOSE-IT and CLOSE_IT were the names allowed +(MU-IMPORT CLOSE_IT CLOSURE) ; last term. This is just like CLOSURE now ... + + +;;;; Predicates and Related Functions + +;;; (TYPE-OF obj) Returns the ULisp datatype of its argument. +;;; +;;; (ATOM obj) returns T if obj is a ULisp atom (non-list), else () +;;; (SYMBOLP obj) returns T if obj is a symbol, else () +;;; (PAIRP obj) returns T if obj is a cons +;;; (LISTP obj) returns T if obj is () or a CONS +;;; (NUMBERP obj) returns T if obj is one of {fixnum, flonum, bignum}, else () +;;; (FIXNUMP obj) returns T if obj is of type fixnum, else () +;;; (BIGNUMP obj) returns T if obj is of type bignum, else () +;;; (FLONUMP obj) returns T if obj is of type flonum, else () +;;; (INTEGERP obj) returns T if obj is of type fixnum or bignum, else () +;;; (NOT obj) returns T if obj is (), else () [same as null] +;;; (NULL obj) returns T if obj is (), else () [same as not] +;;; +;;; (CLOSUREP obj) returns T if obj is a closure, else () +;;; (PROCEDUREP obj) returns T if obj is a procedure, else () +;;; (SPECIAL-FORMP obj) returns T if obj is a special-form, else () +;;; (SUBRP obj) returns T if obj is a subr, else () +;;; +;;; (BOUNDP sym) returns T if sym is bound, else () + +(DEFINE (TYPE-OF X) + (CASEQ (TYPEP X) ; Case on MacLISP type + ((FIXNUM) 'FIXNUM) + ((BIGNUM) 'BIGNUM) + ((FLONUM) 'FLONUM) + ((SYMBOL) (IF X 'SYMBOL 'NULL)) + ((LIST) 'PAIR) + ((ARRAY RANDOM) 'RANDOM) + (T (MU-TYPEP X)))) + +(DEFINE (ATOM X) (NOT (PAIRP X))) +(DEFINE (SYMBOLP X) (AND X (SYMBOLP X))) +(IMPORT PAIRP) ; Import PAIRP definition directly +(IMPORT LISTP LIST?) ; Import LISTP definition directly +(IMPORT NUMBERP) ; Import NUMBERP definition directly +(IMPORT FIXNUMP FIXNUM?) ; Import FIXNUMP definition from FIXNUM? +(IMPORT BIGNUMP BIGP) ; Import BIGNUMP definition from BIGP +(IMPORT FLONUMP FLOATP) ; Import FLONUMP definition from FLOATP +(IMPORT INTEGERP FIXP) ; Import INTEGERP definition from FIXP +(IMPORT NOT) ; Import NOT definition directly +(IMPORT NULL) ; Import NULL definition directly +(IMPORT CLOSUREP CLOSURE?) ; Import CLOSUREP definition from CLOSURE? +(IMPORT PROCEDUREP PROCEDURE?) ; Import PROCEDUREP definition from PROCEDURE? +(IMPORT SPECIAL-FORMP ; Import SPECIAL-FORMP definition from + SPECIAL-FORM?) ; SPECIAL-FORM? +(IMPORT SUBRP SUBR?) ; Import SUBRP definition from SUBR? + +(DEFINE (BOUNDP X) + (MU-CHECK-ARGS 'SYMBOLP X) + (MU-BOUNDP X)) + +;;;; List Manipulation + +;;; (CONS obj1 obj2) returns the dotted pair ( . ) +;;; (LIST obj1 obj2 ...) returns a list made of obj1, obj2, ... +;;; (REVERSE l) Returns a list which is the reverse of l. Does not +;;; side-effect on l. +;;; (LENGTH l) returns the length of the list l. +;;; +;;; (NTHCDR n l) returns the nth cdr of l, n=0 means return l. +;;; +;;; (APPEND l1 l2 ...) appends l1, l2, ... returning the new list. +;;; +;;; (RPLACA obj new-car) Destructively alters the car of obj to be new-car. +;;; (RPLACD obj new-cdr) Destructively alters the cdr of obj to be new-cdr. + +(IMPORT CONS) +(IMPORT LIST) +(IMPORT REVERSE) +(IMPORT LENGTH) +(IMPORT NTHCDR) +(IMPORT APPEND) + +(DEFINE (RPLACA FORM NEW-CAR) + (MU-CHECK-ARGS #'(LAMBDA (X) (EQ (TYPEP X) 'LIST)) FORM) + (RPLACA FORM NEW-CAR)) + +(DEFINE (RPLACD FORM NEW-CDR) + (MU-CHECK-ARGS #'(LAMBDA (X) (EQ (TYPEP X) 'LIST)) FORM) + (RPLACD FORM NEW-CDR)) + +;;; CAR/CDR Composition + +(DEFUN MU-CAR (X) (MU-CHECK-ARGS #'PAIRP X) (CAR X)) +(DEFUN MU-CDR (X) (MU-CHECK-ARGS #'PAIRP X) (CDR X)) + +(DEFINE (CAR X) (MU-CAR X) ) +(DEFINE (CDR X) (MU-CDR X) ) +(DEFINE (CAAR X) (MU-CAR (MU-CAR X)) ) +(DEFINE (CADR X) (MU-CAR (MU-CDR X)) ) +(DEFINE (CDAR X) (MU-CDR (MU-CAR X)) ) +(DEFINE (CDDR X) (MU-CDR (MU-CDR X)) ) +(DEFINE (CAAAR X) (MU-CAR (MU-CAR (MU-CAR X))) ) +(DEFINE (CAADR X) (MU-CAR (MU-CAR (MU-CDR X))) ) +(DEFINE (CADAR X) (MU-CAR (MU-CDR (MU-CAR X))) ) +(DEFINE (CADDR X) (MU-CAR (MU-CDR (MU-CDR X))) ) +(DEFINE (CDAAR X) (MU-CDR (MU-CAR (MU-CAR X))) ) +(DEFINE (CDADR X) (MU-CDR (MU-CAR (MU-CDR X))) ) +(DEFINE (CDDAR X) (MU-CDR (MU-CDR (MU-CAR X))) ) +(DEFINE (CDDDR X) (MU-CDR (MU-CDR (MU-CDR X))) ) +(DEFINE (CAAAAR X) (MU-CAR (MU-CAR (MU-CAR (MU-CAR X))))) +(DEFINE (CAAADR X) (MU-CAR (MU-CAR (MU-CAR (MU-CDR X))))) +(DEFINE (CAADAR X) (MU-CAR (MU-CAR (MU-CDR (MU-CAR X))))) +(DEFINE (CAADDR X) (MU-CAR (MU-CAR (MU-CDR (MU-CDR X))))) +(DEFINE (CADAAR X) (MU-CAR (MU-CDR (MU-CAR (MU-CAR X))))) +(DEFINE (CADADR X) (MU-CAR (MU-CDR (MU-CAR (MU-CDR X))))) +(DEFINE (CADDAR X) (MU-CAR (MU-CDR (MU-CDR (MU-CAR X))))) +(DEFINE (CADDDR X) (MU-CAR (MU-CDR (MU-CDR (MU-CDR X))))) +(DEFINE (CDAAAR X) (MU-CDR (MU-CAR (MU-CAR (MU-CAR X))))) +(DEFINE (CDAADR X) (MU-CDR (MU-CAR (MU-CAR (MU-CDR X))))) +(DEFINE (CDADAR X) (MU-CDR (MU-CAR (MU-CDR (MU-CAR X))))) +(DEFINE (CDADDR X) (MU-CDR (MU-CAR (MU-CDR (MU-CDR X))))) +(DEFINE (CDDAAR X) (MU-CDR (MU-CDR (MU-CAR (MU-CAR X))))) +(DEFINE (CDDADR X) (MU-CDR (MU-CDR (MU-CAR (MU-CDR X))))) +(DEFINE (CDDDAR X) (MU-CDR (MU-CDR (MU-CDR (MU-CAR X))))) +(DEFINE (CDDDDR X) (MU-CDR (MU-CDR (MU-CDR (MU-CDR X))))) + + +;;;; Database Functions + +;;; (MEMQ obj list) Just like Maclisp MEMQ. +;;; (MEMBER obj list) Just like Maclisp MEMBER. +;;; (ASSQ obj alist) Just like Maclisp ASSQ. +;;; (ASSOC obj alist) Just like Maclisp ASSOC. +;;; +;;; (HASH object n) returns an integer between 0 and n-1, inclusive, which can +;;; be used as a hash for object in the range 0-n. +;;; +;;; (PUT sym slot val) puts val in the slot property of sym. +;;; (GET sym slot) gets the slot property of sym or () if none. +;;; + +(IMPORT MEMQ) +(IMPORT MEMBER) +(IMPORT ASSQ) +(IMPORT ASSOC) + +(DECLARE (MUZZLED T)) ; Disable compiler efficiency warnings + +(DEFINE (HASH OBJECT INTEGER) + (MU-CHECK-ARGS #'FIXP INTEGER) + (LET ((NUM (ABS (SXHASH OBJECT)))) + (REMAINDER NUM INTEGER))) + +(DECLARE (MUZZLED ())) ; Re-Enable compiler efficiency warnings + +;;; Property Lists + +(DEFINE (DISPLAY-PLIST SYM) + (MU-CHECK-ARGS #'SYMBOLP SYM) + (LET ((PROPERTY-LIST (CDR (GET SYM 'MU-PROPERTY-LIST)))) + (COND (PROPERTY-LIST + (MU-FORMAT "~%Property list for ~S~%Name Value" SYM) + (DO ((L PROPERTY-LIST (CDDR L))) + ((NULL L)) + (TERPRI *OUTSTREAM*) + (MU-PRIN1 (CAR L) *OUTSTREAM*) + (TYO #\TAB *OUTSTREAM*) + (MU-PP\AUX (CADR L) *OUTSTREAM*))) + (T + (MU-FORMAT "~%~S has no properties.~%" SYM))) + T)) + +; Maybe want a REM here? + +(DEFINE (PUT SYM SLOT VAL) + (MU-CHECK-ARGS #'SYMBOLP SYM) + (LET ((PROPERTY-LIST (GET SYM 'MU-PROPERTY-LIST))) + (COND (PROPERTY-LIST + (PUTPROP PROPERTY-LIST VAL SLOT)) + (T + (PUTPROP SYM (LIST () SLOT VAL) 'MU-PROPERTY-LIST))) + VAL)) + +(DEFINE (GET SYM SLOT) + (MU-CHECK-ARGS #'SYMBOLP SYM) + (DO ((L (CDR (GET SYM 'MU-PROPERTY-LIST)) (CDDR L))) + ((NULL L) ()) + (IF (EQ SLOT (CAR L)) + (RETURN (CADR L))))) + +;;;; Comparison Functions + +;;; (EQ obj1 obj2) returns T if obj1 and obj2 are the same object (occupy the +;;; same address in memory), else () +;;; +;;; (EQUAL obj1 obj2) returns T if both args are atoms and are EQ +;;; or are lists and have an identical arrangement of +;;; terminal nodes, with each such terminal in obj1 +;;; being EQ to the corresponding terminal in obj2. +;;; +;;; (= n1 n2) returns T if n1 and n2 have the same numerical magnitude, else () +;;; It is an error if either n1 or n2 is not a number. +;;; Note: An object of type bignum may fail to compare to an object +;;; of type flonum if it cannot be coerced to a flonum. +;;; +;;; (ZEROP n) returns T if n = 0 (or 0.0), else () +;;; (MINUSP n) returns T if n < 0 (or 0.0), else () +;;; (PLUSP n) returns T if n > 0 (or 0.0), else () +;;; +;;; (GREATERP x1 x2 ...) returns T if x1 is greater than x2..., else () +;;; (> x1 x2 ...) synonym for (greaterp x1 x2 ...) +;;; +;;; (LESSP x1 x2 ...) returns T if x1 is less than x2 ..., else () +;;; (< x1 x2 ...) synonym for (lessp x1 x2 ...) + +(IMPORT EQ) +(IMPORT EQUAL) + +(IMPORT MINUSP) +(IMPORT ZEROP) +(IMPORT PLUSP) + +(IMPORT EQ) +(IMPORT EQUAL) + +(IMPORT ALPHALESSP) + +(DECLARE (MUZZLED T)) ; Disable compiler warnings about closed compilation + +(DEFINE (= X Y) + (MU-CHECK-ARGS 'NUMBERP X Y) + (COND ((AND (BIGP X) (BIGP Y)) ; Both bignums, + (EQUAL X Y)) ; so only EQUAL can win + ((OR (FLOATP X) (FLOATP Y)) ; At least one is a flonum + (= (FLOAT X) (FLOAT Y))) ; compare as flonum + ((OR (BIGP X) (BIGP Y)) ; fixnum < bignum, + ()) ; so fail + (T ; Else, ... + (= (FIXNUM-IDENTITY X) ; we must have fixnums + (FIXNUM-IDENTITY Y))))) ; so just compare straight + +(DECLARE (MUZZLED ())) ; Re-Enable compiler warnings about closed compilation + +( IMPORT GREATERP) +(MU-IMPORT > GREATERP) + +( IMPORT LESSP) +(MU-IMPORT < LESSP) + +;;;; Arithmetic Functions + +;;; (FIX n) converts n to a fixnum or bignum. n must be a number. +;;; (FLOAT n) converts n to a flonum. n must be a number. +;;; +;;; (* n1 n2 ...) or (TIMES n1 n2 ...) returns the product of n1, n2, ... +;;; +;;; (+ n1 n2 ...) or (PLUS n1 n2 ...) returns the sum of n1, n2, ... +;;; +;;; (- n1 n2 n3 ...) or (DIFFERENCE n1 n2 n3 ...) returns n1 - n2 - n3 - ... +;;; +;;; (~ n) or (MINUS n) returns the arithmetic negation of n. +;;; +;;; (1- n) or (SUB1 n) returns n - 1. +;;; +;;; (1+ n) or (ADD1 n) returns n + 1. +;;; +;;; (% x1 x2) or (DIV x1 x2) returns the fixed point quotient of x1/x2. +;;; +;;; (// x1 x2) or (QUOTIENT x1 x2) returns the flonum quotient of x1/x2. +;;; +;;; (\ x1 x2) or (REMAINDER x1 x2) returns the remainder of dividing x1/x2. +;;; +;;; (! x1 x2) or (DIVIDE x1 x2) returns the quotient of x1/x2 +;;; +;;; (\\ x1 x2) or (GCD x1 x2) returns the gcd of x1 and x2. + +(DEFMACRO IMPORT-WITH-DOWNWARD-COERCION (NAME1 &OPTIONAL (NAME2 NAME1)) + `(DEFINE (,NAME1 . X) + (MATH-COERCE-DOWNWARD (APPLY #',NAME2 X)))) + +(DEFMACRO IMPORT-WITH-DUAL-COERCION (NAME1 &OPTIONAL (NAME2 NAME1)) + `(DEFINE (,NAME1 . X) + (MATH-COERCE-DOWNWARD (APPLY #',NAME2 (MATH-COERCE-UPWARD X))))) + +(DECLARE (MUZZLED T)) ; Disable compiler efficiency warnings + +(DEFUN MATH-COERCE-UPWARD (X-LIST) + (DO ((L X-LIST (CDR L))) + ((NULL L) X-LIST) + (IF (FLOATP (CAR X-LIST)) + (RETURN (MAPCAR #'FLOAT X-LIST))))) + +(DEFUN MATH-COERCE-DOWNWARD (X) + (IF (FLOATP X) + (LET ((FX (FIX X))) + (IF (= (FLOAT FX) X) + FX + X)) + X)) + +(IMPORT FIX) ; Import FIX directly +(IMPORT FLOAT) ; Import FLOAT directly + +(IMPORT-WITH-DOWNWARD-COERCION TIMES) +(MU-IMPORT * TIMES) ; Make * inherit TIMES' definition + +(IMPORT-WITH-DOWNWARD-COERCION PLUS) +(MU-IMPORT + PLUS) ; Make + inherit PLUS' definition + +(IMPORT-WITH-DOWNWARD-COERCION DIFFERENCE) +(MU-IMPORT - DIFFERENCE) ; Make - inherit DIFFERENCE's definition + +(IMPORT-WITH-DOWNWARD-COERCION MINUS) +(MU-IMPORT ~ MINUS) ; Make ~ inherit DIFFERENCE's definition + +(IMPORT-WITH-DOWNWARD-COERCION SUB1) +(MU-IMPORT 1- SUB1) ; Make 1- inherit SUB1's definition + +(IMPORT-WITH-DOWNWARD-COERCION ADD1) +(MU-IMPORT 1+ ADD1) ; Make 1+ inherit ADD1's definition + +(DEFINE (DIV X1 X2) + (MU-CHECK-ARGS #'NUMBERP + (SETQ X1 (MATH-COERCE-DOWNWARD X1)) + (SETQ X2 (MATH-COERCE-DOWNWARD X2))) + (COND ((AND (MINUSP X1) (MINUSP X2)) + (MU-CALL DIV (MINUS X1) (MINUS X2))) + ((MINUSP X1) + (MINUS (MU-CALL DIV (MINUS X1) X2))) + ((MINUSP X2) + (MINUS (MU-CALL DIV X1 (MINUS X2)))) + (T ; X1, X2 known positive + (COND ((AND (FIXP X1) (FIXP X2)) + (// X1 X2)) + (T + (LET ((GUESS (// (FIX X1) (FIX X2))) + (X1 (FLOAT X1)) + (X2 (FLOAT X2))) + (DECLARE (FIXNUM GUESS) (FLONUM X1 X2)) + (DO ((TOTAL (*$ (FLOAT GUESS) X2) (+$ TOTAL X2))) + ((> TOTAL X1) + (DO () ((NOT (> TOTAL X1)) GUESS) + (SETQ TOTAL (-$ TOTAL X2)) + (SETQ GUESS (1- GUESS)))) + (DECLARE (FLONUM TOTAL)) + (SETQ GUESS (1+ GUESS))))))))) + + +(MU-IMPORT % DIV) ; Make % inherit DIV's definition + +(DEFINE (QUOTIENT X1 X2) + (MU-CHECK-ARGS #'NUMBERP X1 X2) + (//$ (FLOAT X1) (FLOAT X2))) + +(MU-IMPORT // QUOTIENT) + +(DEFINE (DIVIDE X Y) ; Generalized Quotient + (MU-CHECK-ARGS #'NUMBERP X Y) + (LET ((Q-FLO (//$ (FLOAT X) (FLOAT Y))) + (Q-FIX (// (FIX X) (FIX Y)))) + (IF (= Q-FLO (FLOAT Q-FIX)) Q-FIX Q-FLO))) + +(MU-IMPORT ! DIVIDE) ; Make ! be like DIVIDE + +(DEFINE (REMAINDER X Y) + (MU-CHECK-ARGS #'NUMBERP X Y) + (MATH-COERCE-DOWNWARD + (DIFFERENCE X (TIMES (MU-CALL DIV X Y) Y)))) + +(MU-IMPORT \ REMAINDER) + +(DEFINE (GCD X Y) + (MU-CHECK-ARGS #'NUMBERP + (SETQ X (MATH-COERCE-DOWNWARD X)) + (SETQ Y (MATH-COERCE-DOWNWARD Y))) + (GCD X Y)) ; Returns fixed point only -- fails on floating + +(MU-IMPORT \\ GCD) + +(IMPORT-WITH-DOWNWARD-COERCION SIN) +(IMPORT-WITH-DOWNWARD-COERCION COS) +(IMPORT-WITH-DOWNWARD-COERCION ATAN) +(IMPORT-WITH-DOWNWARD-COERCION SQRT) + +(DECLARE (MUZZLED ())) ; ReEnable compiler efficiency warnings + + +;;;; I/O Functions + +;;; OUTPUT +;;; (TYO n) types the character whose ascii value is n on the console. +;;; (TERPRI) types a carriage return. +;;; (PRINC form) types form on terminal in human-readable syntax. +;;; (PRIN1 form) types form on terminal in lisp-readable syntax. +;;; (PRINT form) prin1's form on terminal preceded by crlf and ended with " ". +;;; +;;; Note: All output operations return their argument. +;;; +;;; INPUT +;;; (PEEKCH) peeks at a char [symbol] from the input stream w/o reading it. +;;; (READCH) reads a char [symbol] from the input stream. +;;; (TYI) reads a char [fixnum] from the input stream, returning it. +;;; (TYIPEEK) peeks at a char [fixnum] from the input stream w/o reading it. +;;; (READ) reads a lisp S-Expression from the input stream. +;;; +;;; MISC +;;; (EXPLODEC form) returns list of chars that would be typed by (PRINC form). +;;; (EXPLODE form) returns list of chars that would be typed by (PRIN1 form). +;;; (IMPLODE list) like READ but reads chars from list, rather than terminal. +;;; (IMPLODEC list) returns an interned symbol whose pname is symbols in list. +;;; (GENSYM) returns a unique, uninterned symbol (not EQ to any other symbol). +;;; (CVTA n) returns the ascii character (symbol) whose numeric value is n. +;;; (CVTN sym) returns the numeric code of the ascii char (symbol) sym. + +(DEFINE (TYO X) (TYO X *OUTSTREAM*)) + +(DEFINE (TERPRI) (TERPRI *OUTSTREAM*)) + +(DEFINE (PRINC FORM) + (MU-PRINC FORM *OUTSTREAM*) + FORM) + +(DEFINE (PRIN1 FORM) + (MU-PRIN1 FORM *OUTSTREAM*) + FORM) + +(DEFINE (PRINT FORM) + (TERPRI *OUTSTREAM*) + (MU-PRIN1 FORM *OUTSTREAM*) + (TYO #\SPACE *OUTSTREAM*) + FORM) + +(DEFINE (PEEKCH) (ASCII (TYIPEEK))) + +(DEFINE (READCH) (READCH)) + +(DEFINE (TYIPEEK) (TYIPEEK)) + +(DEFINE (TYI) (TYI)) + +(DEFINE (READ) + (LET ((RETURN-VALUE (MU-READ))) + (IF ^Q ; Is input coming from a file? + (MU-PRIN1 RETURN-VALUE *OUTSTREAM*) + (IF (AND *SCRIPT-STREAM* ; Scripting, + (NOT ECHOFILES)) ; but echo output disabled + (MU-PRIN1 RETURN-VALUE *SCRIPT-STREAM*))) ; fix that! + RETURN-VALUE)) + +(DEFINE (IMPLODE L) (MU-IMPLODE L)) + +(DEFINE (IMPLODEC L) (IMPLODE L)) + +(DEFINE (EXPLODEC FORM) (MU-EXPLODE FORM 'MU-PRINC)) + +(DEFINE (EXPLODE FORM) (MU-EXPLODE FORM 'MU-PRIN1)) + +(DEFINE (GENSYM) + (GENSYM)) + +(DEFINE (CVTA X) (ASCII X)) +(DEFINE (CVTN X) (GETCHARN X 1.)) + +;;;; File I/O + +;;; (LOAD '(filename1 filename2 dev dir) [flag]) +;;; +;;; Reads from specified filename. If no flag is given, or if flag is (), +;;; does no typeout during read. If flag is non-(), types out result of +;;; each evaluation as it happens. Returns T when read is completed. + +(DEFINE (LOAD . X) + (IF (OR (NULL X) (> (LENGTH X) 2.)) + (MU-ERROR "Wrong number of args to LOAD" (CONS 'LOAD X))) + (LET* (((FILENAME PRINT-FLAG) X) + (EOF (GENSYM)) + (IBASE *IBASE*) + (NAME (PROBEF (SETQ FILENAME (MERGEF FILENAME DEFAULTF))))) + (COND ((NOT NAME) (MU-ERROR "File not found" FILENAME))) + (IOTA ((INSTREAM FILENAME 'IN)) + (LET ((INFILE INSTREAM) + (ECHOFILES ()) + (^Q T)) + (IF PRINT-FLAG + (MU-FORMAT "~%;Loading /"~A/" ..." + (NAMESTRING (PROBEF (NAMELIST INSTREAM))))) + (DO ((FORM (MU-READ INSTREAM EOF) + (MU-READ INSTREAM EOF))) + ((EQ FORM EOF) + (IF PRINT-FLAG + (MU-FORMAT "~%;Loading of /"~A/" done.~%" + (NAMESTRING (PROBEF (NAMELIST INSTREAM))))) + T) + (COND (PRINT-FLAG + (MU-PRIN1 (PROG1 (MU-EVAL FORM) (TERPRI *OUTSTREAM*)) + *OUTSTREAM*)) + (T + (MU-EVAL FORM)))))))) + +;;;; Miscellaneous Functions + +;;; (GC) invokes the garbage collector. +;;; +;;; (LPR-ON [fileobj]) Opens a stream to a wallpaper file recording +;;; console session. Returns () if a file is already open, +;;; else T if succeeds. If file is given, uses that instead +;;; of default lpr stream as a destination. +;;; +;;; (LPR-OFF) Closes a wallpaper file. Returns () if no file open, else +;;; T if succeeds. +;;; +;;; +;;; (RANDOM n) returns a random number between 0 and x +;;; +;;; (SETRANDOM ()) randomizes the random number generator. +;;; (SETRANDOM n) initializes the random number generator with n as its seed. + +(DEFINE (GC) + (GCTWA) (GC) T) + +(DEFINE (LPR-ON . X) + (IF (AND X (CDR X)) + (MU-ERROR "Wrong number of args to LPR-ON" X)) + (LET ((FILENAME (IF X (CAR X) *SCRIPT-NAME*))) + (COND (*SCRIPT-STREAM* ()) + (T (SETQ ^R T) + (SETQ *SCRIPT-STREAM* (OPEN FILENAME 'OUT)) + (PUSH *SCRIPT-STREAM* *OUTSTREAMS*) + (PUSH *SCRIPT-STREAM* ECHOFILES) + (PUSH *SCRIPT-STREAM* MSGFILES) + T)))) + +(DEFINE (LPR-OFF) + (COND ((NOT *SCRIPT-STREAM*) ()) + (T (SETQ ^R ()) + (SETQ MSGFILES (DELETE *SCRIPT-STREAM* MSGFILES)) + (SETQ ECHOFILES (DELETE *SCRIPT-STREAM* ECHOFILES)) + (SETQ *OUTSTREAMS* + (DELETE *SCRIPT-STREAM* *OUTSTREAMS*)) + (CLOSE *SCRIPT-STREAM*) + (SETQ *SCRIPT-STREAM* ()) + T))) + +(DEFINE (RANDOM N) + (MU-CHECK-ARGS 'FIXP N) + (RANDOM N)) + +(DEFINE (SETRANDOM N) + (COND ((NULL N) + (SSTATUS RANDOM + (APPLY #'* (APPEND (STATUS DATE) (STATUS DAYTIME))))) + ((FIXNUM? N) + (SSTATUS RANDOM N)) + (T + (MU-ERROR "Arg to SETRANDOM must be a FIXNUM or ()" N)))) + +;;;; Switches + +;;; (PRINLEVEL T) returns the current prinlevel +;;; (PRINLEVEL v) sets the prinlevel to v (fixnum or ()) +;;; +;;; (PRINLENGTH T) returns the current prinlength +;;; (PRINLENGTH v) sets the prinlength to v (fixnum or ()) +;;; +;;; (INRADIX T) returns the current radix being used by 'read' +;;; (INRADIX n) sets the input radix to n +;;; +;;; (OUTRADIX T) returns the current radix being used by 'print', etc. +;;; (OUTRADIX n) sets the output radix to n. + +(DEFINE (PRINLEVEL N) + (COND ((EQ N 'T) *PRINLEVEL*) + ((OR (NULL N) (FIXNUM? N)) (SETQ *PRINLEVEL* N)) + (T + (MU-ERROR "Arg to PRINLEVEL must be a fixnum, (), or T" N)))) + + +(DEFINE (PRINLENGTH N) + (COND ((EQ N 'T) *PRINLENGTH*) + ((OR (NULL N) (FIXNUM? N)) (SETQ *PRINLENGTH* N)) + (T + (MU-ERROR "Arg to PRINLENGTH must be a fixnum, (), or T" N)))) + +(DEFINE (INRADIX N) + (COND ((EQ N 'T) *IBASE*) + ((OR (NOT (FIXNUM? N)) (< N 2.) (> N 36.)) + (MU-ERROR "Arg to INRADIX must be T or fixnum, 1 < x < 37" N)) + (T + (SETQ *IBASE* N)))) + +(DEFINE (OUTRADIX N) + (COND ((EQ N 'T) *OBASE*) + ((OR (NOT (FIXNUM? N)) (< N 2.) (> N 36.)) + (MU-ERROR "Arg to OUTRADIX must be T or fixnum, 1 < x < 37" N)) + (T + (SETQ *OBASE* N)))) + +;;;; The ULisp Stack Debugger + +(DEFVAR *DEBUG-LEVEL* 0.) ; An internal counter to the debugger +(DEFVAR *DEBUG-OPTIONS* ()) ; A list of the DEBUG options we have available + +; ------------------------- Support for Support ---------------------- + +(DEFMACRO DEF-DEBUG-OPTION (NAME DOCUMENTATION &REST BODY) + `(PROGN 'COMPILE + (DEFUN (,NAME MU-DEBUG-OPTION) () ,@BODY) + (DEFPROP ,NAME ,DOCUMENTATION MU-DEBUG-OPTION-DOCUMENTATION) + (PUSH ',NAME *DEBUG-OPTIONS*))) + +(DEFMACRO MU-CALL-DEBUG-OPTION (OPT) + `(FUNCALL (GET ',OPT 'MU-DEBUG-OPTION))) + +(DEFMACRO MU-DEBUG-CURSOR () '(NTHCDR *DEBUG-LEVEL* *BACKLIST*)) + +; ----------------------------- Support ------------------------------ + +(DEFUN MU-READ-DEBUG-COMMAND () + (LET ((C (TYI TYI))) + (ASCII (IF (AND (NOT (< C #/a)) (NOT (> C #/z))) + (- C #o40) + C)))) + +(DEFUN MU-DEBUG-1 () + (MU-FORMAT "~%[Debug]") + (LET* ((C (MU-READ-DEBUG-COMMAND)) + (DEBUG-OPTION (GET C 'MU-DEBUG-OPTION))) + (COND (DEBUG-OPTION (FUNCALL DEBUG-OPTION)) + ((MEMQ C '(? HELP)) ; Default help information + (PRINC " -- Help not available!" *OUTSTREAM*)) + ((MEMBER C '(#.(ASCII #\FORM) ; These characters + #.(ASCII #\RETURN) ; should be no-ops unless + #.(ASCII #\LINEFEED) ; otherwise defined + #.(ASCII #\SPACE) + #.(ASCII #\TAB)))) + (T (PRINC " ??" *OUTSTREAM*))))) + +(DEFUN MU-DOCUMENT-DEBUG-OPTION (C) + (TERPRI *OUTSTREAM*) + (PRINC C *OUTSTREAM*) + (LET ((DOC (GET C 'MU-DEBUG-OPTION-DOCUMENTATION))) + (COND (DOC (PRINC " - " *OUTSTREAM*) + (PRINC DOC *OUTSTREAM*)) + (T + (PRINC " is not an option." *OUTSTREAM*))))) + +(DEFUN MU-SHOW-BACKLIST-FRAME (PRINTER) + (LET ((CURSOR (MU-DEBUG-CURSOR))) + (COND ((NULL (CDR CURSOR)) + (PRINC " Bottom" *OUTSTREAM*)) + ((ZEROP *DEBUG-LEVEL*) + (PRINC " Top" *OUTSTREAM*))) + (TYO 9. *OUTSTREAM*) + (FUNCALL PRINTER (CAR CURSOR) *OUTSTREAM*))) + +; --------------------------- User Functions --------------------------- + +(IMPORT EDIT MU-LEDIT) + +(DEFINE (DEBUG) + (*CATCH 'MU-DEBUG-EXIT + (DO ((*DEBUG-LEVEL* 0.)) (NIL) + (*CATCH 'MU-ERROR-RETURN (MU-DEBUG-1)))) + (MU-FORMAT "~%;Debugger Terminated.~%") + T) + + +;;;; Debugger Command Definitions + +(DEF-DEBUG-OPTION /? "Gives brief help summary." + (MU-FORMAT "~%Commands are one char. H documents a command. Q exits.")) + +(DEF-DEBUG-OPTION /Q "Exits the debugger." + (MU-FORMAT "~%Exit Debug~%") + (*THROW 'MU-DEBUG-EXIT T)) + +(DEF-DEBUG-OPTION /H "Describes 1 or all commands." + (MU-FORMAT "~%Type a char to document or /"*/" for all: ") + (LET ((C (MU-READ-DEBUG-COMMAND))) + (COND ((EQ C '*) + (DO ((L *DEBUG-OPTIONS* (CDR L))) + ((NULL L)) + (MU-DOCUMENT-DEBUG-OPTION (CAR L)))) + (T + (MU-DOCUMENT-DEBUG-OPTION C))))) + +(DEF-DEBUG-OPTION /F "Prints out all stack frames in abbreviated form." + (DO ((L *BACKLIST* (BACKLIST-PARENT L)) + (*PRINLEVEL* 2.) + (*PRINLENGTH* 4.) + (I 0. (1+ I))) ; Count level numbers + ((NULL L)) + (TERPRI *OUTSTREAM*) + (COND ((= I *DEBUG-LEVEL*) (PRINC "> " *OUTSTREAM*)) + (T (PRINC " " *OUTSTREAM*))) + (MU-FORMAT "~D./ " I) + (MU-PRIN1 (BACKLIST-FORM L) *OUTSTREAM*))) + +(DEF-DEBUG-OPTION /. + "Prints currently selected stack frame in abbreviated form." + (LET ((*PRINLEVEL* 2.) (*PRINLENGTH* 4.)) + (MU-SHOW-BACKLIST-FRAME 'MU-PRIN1))) + +(DEF-DEBUG-OPTION /T "Types out currently selected stack frame normally." + (MU-SHOW-BACKLIST-FRAME 'MU-PRIN1)) + +(DEF-DEBUG-OPTION /P "Pretty-Prints currently selected stack frame." + (MU-SHOW-BACKLIST-FRAME 'MU-PP\AUX)) + +(DEF-DEBUG-OPTION /D "Goes down one stack frame." + (COND ((NULL (BACKLIST-PARENT (MU-DEBUG-CURSOR))) + (TYO #\BELL TYO)) ; Beep on terminal only + (T + (SETQ *DEBUG-LEVEL* (1+ *DEBUG-LEVEL*)))) + (MU-CALL-DEBUG-OPTION /.)) + +(DEF-DEBUG-OPTION /U "Goes up one stack frame." + (COND ((ZEROP *DEBUG-LEVEL*) + (TYO #\BELL TYO)) ; Beep on terminal only + (T + (SETQ *DEBUG-LEVEL* (1- *DEBUG-LEVEL*)))) + (MU-CALL-DEBUG-OPTION /.)) + +(DEF-DEBUG-OPTION /G "Asks for a frame number and goes to it." + (MU-FORMAT "~%Go To Frame Number: ") + (LET* ((IBASE 10.) (N (READ))) + (TYI) ; Read or which ended N + (IF (OR (NOT (NUMBERP N)) (MINUSP N) (NOT (FIXP N))) + (MU-FORMAT "Invalid stack frame number.") + (LET ((FRAME (NTHCDR N *BACKLIST*))) + (IF (NOT FRAME) + (MU-FORMAT "Invalid stack frame number.") + (SETQ *DEBUG-LEVEL* N) + (MU-CALL-DEBUG-OPTION /.)))))) + +(DEF-DEBUG-OPTION /E "Prints error information." + (IF (NOT *ERRFRAME*) + (MU-FORMAT "~%No Pending Error") + (MU-FORMAT "~%Error Message: ") + (MU-PRIN1 (ERROR-MESSAGE *ERRFRAME*) *OUTSTREAM*) + (MU-FORMAT "~%Error Data: ") + (MU-PRIN1 (ERROR-DATA *ERRFRAME*) *OUTSTREAM*))) + +(DEF-DEBUG-OPTION /A "Goes to top of stack." + (SETQ *DEBUG-LEVEL* 0.) + (MU-CALL-DEBUG-OPTION /.)) + +(DEF-DEBUG-OPTION /Z "Goes to bottom of stack." + (SETQ *DEBUG-LEVEL* (1- (LENGTH *BACKLIST*))) + (MU-CALL-DEBUG-OPTION /.)) + +(DEF-DEBUG-OPTION /B "Gives debug breakpoint at current stack frame." + (LET ((*ENV* (BACKLIST-ENV (MU-DEBUG-CURSOR))) + (*BACKLIST* (MU-DEBUG-CURSOR))) + (MU-BREAK-LOOP "Debug") + (COND ((= (TYIPEEK) #\SPACE) (TYI))))) + +;;;; Environment Initialization + +(SSTATUS FEATURE NOLDMSG) ; Disable autoload messages +(SSTATUS _ ()) ; Disable _-style typeout + +;;; Options + +(SETQ ; Maclisp magic variables + BASE 10. ; Output Base = 10 + IBASE 10. ; Input Base = 10 + *NOPOINT T ; Don't print decimal point for base 10 numbers + *RSET T ; Tell lisp to do error checks + NOUUO () ; Enable snapping of UUO links + MAKHUNK () ; Don't allow (a . b . c .) input syntax for hunks + ) + +;;; Variables used by the Micro-Evaluator + +(MU-SET 'T 'T ) ; T should self-eval initially -- heaven help anyone + ; who binds it! +(SETQ + *BACKLIST* () + *BREAK-LEVEL* 0. + *DEBUG* T + *ERRFRAME* () + *EVAL-BEFORE-DUMP* () + *EVAL-AFTER-DUMP* () + *EXPLODE-SFA* (SFA-CREATE 'MU-EXPLODE-HANDLER 0. "Explode Handler") + *FLATSIZE-SFA* (SFA-CREATE 'MU-FLATSIZE-HANDLER 0. "Flatsize Handler") + *IBASE* 10. + *IMPLODE-SFA* (SFA-CREATE 'MU-IMPLODE-HANDLER 0. "Implode Handler") + *LEX* () + *OBASE* 10. + *OUTSTREAM* (SFA-CREATE 'MU-OUTSTREAM-HANDLER 0. "Output Handler") + *OUTSTREAMS* (NCONS TYO) + *PRINLENGTH* () + *PRINLEVEL* () + *PRINLEVEL-COUNT* 0. + *SCRIPT-STREAM* () + *SLASHIFY* T + *SYSDEBUG* T + *TRACE-LEVEL* 0. + *ULISP* () + *ULISP-FEATURES* "" + ) +