PDP-10.its/src/teach/ulisp.459

;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- 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 #<CLOSURE definition>
 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 #<PROCEDURE definition>
 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 #<SPECIAL-FORM nnnn>
 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 #<SUBR name>
 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)   ; #<PROCEDURE definition>
       (CONS 'LAMBDA (PROCEDURE-DEFINITION X)))

(DEFUN MU-CLOSURE-PNGEN (X)	; #<CLOSURE definition>
       (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 <form1> <form2> ...)
;;;
;;;  Evaluates <form1>, <form2>, ... 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 "#<MacLisp-Object "     STREAM)
	      (PRIN1 OBJECT STREAM)
	      (PRINC ">"	     STREAM)))
       OBJECT)

;;;; Psuedo-I/O Functions

;;; (MU-FLATSIZE <form> <printer>) - 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 #<MACRO definition>
 MU-MACRO-EVHOOK			; evaluates body magically
 ()					; macros are not applicable
 PROCEDURE)				; definition

;;; (MU-MACRO-PNGEN obj)
;;;  Allows macros to print as #<MACRO name> 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 #<TRACED name>
 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 (<obj1> . <obj2>)
;;; (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 <Sp> or <Cr> 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*  ""
      )