;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- 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* "" )