add merge in Ron's 11/21/2020 lispcore

CLTL2/ADVISE

@@ -0,0 +1,269 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
+
(IL:FILECREATED " 6-Jan-92 15:12:26" IL:|{DSK}<usr>local>lde>lispcore>sources>ADVISE.;2|
 31117  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION FINISH-ADVISING)
+
+      IL:|previous| IL:|date:| "16-May-90 11:55:52" IL:|{DSK}<usr>local>lde>lispcore>sources>ADVISE.;1|
+)
+
+
+; Copyright (c) 1978, 1984, 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+; The following program was created in 1978 but has not been published
+; within the meaning of the copyright law, is furnished under license,
+; and may not be used, copied and/or disclosed except in accordance
+; with the terms of said license.
+
+(IL:PRETTYCOMPRINT IL:ADVISECOMS)
+
+(IL:RPAQQ IL:ADVISECOMS ((IL:STRUCTURES ADVICE) (IL:VARIABLES IL:ADVISEDFNS *UNADVISED-FNS*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:FNS IL:ADVISE IL:UNADVISE IL:READVISE) (IL:PROP IL:ARGNAMES IL:ADVISE) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION) (IL:FUNCTIONS UNADVISE-FROM-RESTORE-CALLS FINISH-ADVISING FINISH-UNADVISING) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (IL:VARIABLES *ADVICE-HASH-TABLE*) (IL:FUNCTIONS ADD-ADVICE DELETE-ADVICE GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN INSERT-ADVICE-FORM) (IL:SETFS GET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (IL:FUNCTIONS CREATE-ADVISED-DEFINITION MAKE-AROUND-BODY) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:FILEPKGCOMS IL:ADVICE IL:ADVISE) (IL:FUNCTIONS XCL:REINSTALL-ADVICE) (IL:FUNCTIONS ADVICE-GETDEF ADVICE-PUTDEF ADVICE-DELDEF ADVICE-HASDEF ADVICE-NEWCOM ADVICE-FILE-DEFINITIONS ADVISE-CONTENTS ADVICE-ADDTOCOM) (IL:PROP IL:PROPTYPE IL:ADVISED) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (IL:FUNCTIONS IL:READVISE1 ADD-OLD-STYLE-ADVICE CANONICALIZE-ADVICE-SYMBOL CANONICALIZE-ADVICE-WHEN-SPEC CANONICALIZE-ADVICE-WHERE-SPEC) (IL:DEFINE-TYPES XCL:ADVISED-FUNCTIONS) (IL:FUNCTIONS XCL:DEFADVICE) (IL:* IL:|;;| "Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package.") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:ADVISE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA IL:READVISE IL:UNADVISE) (IL:NLAML) (IL:LAMA IL:ADVISE)))))
+
+(DEFSTRUCT (ADVICE (:TYPE LIST)) BEFORE AFTER AROUND)
+
+(DEFVAR IL:ADVISEDFNS NIL)
+
+(DEFVAR *UNADVISED-FNS* NIL)
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "Interlisp entry points.")

+
+(IL:DEFINEQ
+
+(il:advise

+  (il:lambda il:args
                                  (il:* il:\; "Edited  6-Apr-87 18:00 by Pavel")

+
+(il:* il:|;;;| "ADVISE the FN given.  ADVISE1 is for advice of the type (foo IN bar)")

+
+    (let (il:fn il:when il:where il:what)
+          
+          (il:* il:|;;| "First we straighten out the arguments given to us")

+
+         (il:setq il:fn (il:arg il:args 1))
+         (case il:args (2 (il:setq il:what (il:arg il:args 2)))
+               (3 (il:setq il:when (il:arg il:args 2))
+                  (il:setq il:what (il:arg il:args 3)))
+               (4 (il:setq il:when (il:arg il:args 2))
+                  (il:setq il:where (il:arg il:args 3))
+                  (il:setq il:what (il:arg il:args 4)))
+               (t (il:if
 (< il:args 2)
+                      il:then
 (error 'il:too-few-arguments :callee 'il:advise :actual il:args 
+                                     :minimum 2)
+                    il:else
 (error 'il:too-many-arguments :callee 'il:advise :actual il:args :maximum 
+                                   4))))
+         (il:setq il:when (canonicalize-advice-when-spec il:when))
+         (il:setq il:where (canonicalize-advice-where-spec il:where))
+         (il:if
 (il:nlistp il:fn)
+             il:then
 (xcl:advise-function il:fn il:what :when il:when :priority il:where)
+           il:elseif
 (il:string.equal (cadr il:fn)
+                            "IN")
+             il:then
 (xcl:advise-function (first il:fn)
+                            il:what :in (third il:fn)
+                            :when il:when :priority il:where)
+           il:else
 (il:for
 il:x il:in
 il:fn
+                      il:join
 (il:if
 (il:nlistp il:x)
+                                  il:then
 (xcl:advise-function il:x il:what :when il:when :priority 
+                                                 il:where)
+                                il:else
 (xcl:advise-function (first il:x)
+                                               il:what :in (third il:x)
+                                               :when il:when :priority il:where)))))))
+
+(il:unadvise

+  (il:nlambda il:fns
                                  (il:* il:\; "Edited  6-Apr-87 16:21 by Pavel")

+    (il:setq il:fns (il:nlambda.args il:fns))
+    (flet ((il:unadvise-entry (il:entry)
+                  (il:if
 (il:listp il:entry)
+                      il:then
 (xcl::unadvise-function (first il:entry)
+                                     :in
+                                     (third il:entry))
+                    il:else
 (xcl::unadvise-function il:entry))))
+          (cond
+             ((null il:fns)
+              (il:for
 il:entry il:in
 (il:reverse il:advisedfns) il:join
 (il:unadvise-entry il:entry))
+              )
+             ((il:equal il:fns '(t))
+              (and (not (null il:advisedfns))
+                   (il:unadvise-entry (car il:advisedfns))))
+             (t (il:for
 il:entry il:in
 il:fns il:join
 (il:unadvise-entry il:entry)))))))
+
+(il:readvise

+  (il:nlambda il:fns
                                  (il:* il:\; "Edited  6-Apr-87 16:52 by Pavel")

+    (il:setq il:fns (il:nlambda.args il:fns))
+    (flet ((il:readvise-entry (il:entry)
+                  (il:if
 (il:listp il:entry)
+                      il:then
 (xcl::readvise-function (first il:entry)
+                                     :in
+                                     (third il:entry))
+                    il:else
 (xcl::readvise-function il:entry))))
+          (cond
+             ((null il:fns)                                  (il:* il:\; 
+
                                                             "readvise them all, in reverse order.")

+              (il:for
 il:entry il:in
 (il:reverse *unadvised-fns*) il:join
 (il:readvise-entry il:entry
+                                                                                 )))
+             ((il:equal il:fns '(t))                         (il:* il:\; 
+
                                        "simple case, readvise just the last one that was unadvised.")

+              (and (not (null *unadvised-fns*))
+                   (il:readvise-entry (car *unadvised-fns*))))
+             (t                                              (il:* il:\; "they gave us some functions, so readvise THEM.  We can't use READVISE-ENTRY here, because we may have to deal with old-style advice.")

+                (il:for
 il:entry il:in
 il:fns il:join
 (il:readvise1 il:entry)))))))
+)
+
+(IL:PUTPROPS IL:ADVISE IL:ARGNAMES (IL:WHO IL:WHEN IL:WHERE IL:WHAT))
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "XCL entry points.")

+
+
+(DEFUN XCL:ADVISE-FUNCTION (XCL::FN-TO-ADVISE XCL::FORM &KEY ((:IN XCL::IN-FN)) (WHEN :BEFORE) (XCL::PRIORITY :LAST)) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-ADVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-ADVISE) (COND ((AND (CONSP XCL::FN-TO-ADVISE) (NOT XCL::EXECUTABLE-TO-ADVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-ADVISE IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN XCL::FORM :IN XCL::IN-FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:ADVISE-FUNCTION XCL::FN-TO-ADVISE XCL::FORM :IN XCL::FN :WHEN WHEN :PRIORITY XCL::PRIORITY))) (T (LET (XCL::EXECUTABLE-TO-ADVISE-IN) (COND ((NULL XCL::FORM) (FORMAT *ERROR-OUTPUT* "No advice given, so nothing done.") NIL) ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-ADVISE "advise") (FORMAT *ERROR-OUTPUT* "~S not advised.~%" XCL::FN-TO-ADVISE) NIL) (T (COND (XCL::IN-FN (SETQ XCL::EXECUTABLE-TO-ADVISE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-ADVISE-IN XCL::EXECUTABLE-TO-ADVISE)) (ERROR "~S is not called from ~S." XCL::FN-TO-ADVISE XCL::IN-FN))) (T (IF (NULL (IL:GETD XCL::EXECUTABLE-TO-ADVISE)) (ERROR (QUOTE XCL:UNDEFINED-FUNCTION) :NAME XCL::FN-TO-ADVISE)))) (XCL:UNBREAK-FUNCTION XCL::FN-TO-ADVISE :IN XCL::IN-FN :NO-ERROR T) (COND ((NULL XCL::IN-FN) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT (MEMBER XCL::FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQ))) (IL:* IL:\; "If FN-TO-ADVISE is not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::FN-TO-ADVISE)) (ADD-ADVICE XCL::FN-TO-ADVISE WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;| "Finish off the process.  This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE XCL::EXECUTABLE-TO-ADVISE)) (T (LET* ((XCL::ADVICE-NAME (IL:BQUOTE ((IL:\\\, XCL::FN-TO-ADVISE) :IN (IL:\\\, XCL::IN-FN)))) (XCL::ALREADY-ADVISED? (MEMBER XCL::ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:* IL:|;;| "Adjust the database of advice for this request.") (WHEN (NOT XCL::ALREADY-ADVISED?) (IL:* IL:\; "If not currently advised, the new advice replaces any that may have been given before.") (DELETE-ADVICE XCL::ADVICE-NAME)) (ADD-ADVICE XCL::ADVICE-NAME WHEN XCL::PRIORITY XCL::FORM) (IL:* IL:|;;| "Finish off the process.  This part is shared with READVISE-FUNCTION.") (FINISH-ADVISING XCL::FN-TO-ADVISE XCL::EXECUTABLE-TO-ADVISE XCL::IN-FN XCL::EXECUTABLE-TO-ADVISE-IN)))))))))))
+
+(DEFUN XCL:UNADVISE-FUNCTION (XCL::FN-TO-UNADVISE &KEY ((:IN XCL::IN-FN)) XCL::NO-ERROR) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-UNADVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-UNADVISE) (COND ((AND (CONSP XCL::FN-TO-UNADVISE) (NOT XCL::EXECUTABLE-TO-UNADVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-UNADVISE IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:UNADVISE-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::FN))) (T (XCL:UNBREAK-FUNCTION XCL::FN-TO-UNADVISE :IN XCL::IN-FN :NO-ERROR T) (IF (NULL XCL::IN-FN) (LET ((XCL::ORIGINAL (GET XCL::EXECUTABLE-TO-UNADVISE (QUOTE IL:ADVISED)))) (COND ((NULL XCL::ORIGINAL) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::FN-TO-UNADVISE)) NIL) (T (IL:PUTD XCL::EXECUTABLE-TO-UNADVISE (IL:GETD XCL::ORIGINAL) T) (REMPROP XCL::EXECUTABLE-TO-UNADVISE (QUOTE IL:ADVISED)) (PUSH XCL::FN-TO-UNADVISE *UNADVISED-FNS*) (SETQ IL:ADVISEDFNS (DELETE XCL::FN-TO-UNADVISE IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (LIST XCL::FN-TO-UNADVISE)))) (IF XCL::NO-IN-FN (ERROR "~S can't be selectively unadvised :IN ~S" XCL::FN-TO-UNADVISE XCL::IN-FN) (LET* ((XCL::EXECUTABLE-TO-UNADVISE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (XCL::ADVICE-NAME (IL:BQUOTE ((IL:\\\, XCL::FN-TO-UNADVISE) :IN (IL:\\\, XCL::IN-FN)))) (XCL::MIDDLE-MAN (GET-ADVICE-MIDDLE-MAN XCL::ADVICE-NAME))) (COND ((NULL XCL::MIDDLE-MAN) (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not advised.~%" XCL::ADVICE-NAME)) NIL) (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::EXECUTABLE-TO-UNADVISE XCL::EXECUTABLE-TO-UNADVISE-IN) (FINISH-UNADVISING XCL::ADVICE-NAME XCL::MIDDLE-MAN) (LIST XCL::ADVICE-NAME))))))))))
+
+(DEFUN XCL:READVISE-FUNCTION (XCL::FN-TO-READVISE &KEY ((:IN XCL::IN-FN))) (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-READVISE XCL::NO-IN-FN) (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-READVISE) (COND ((AND (CONSP XCL::FN-TO-READVISE) (NOT XCL::EXECUTABLE-TO-READVISE)) (IL:FOR XCL::FN IL:IN XCL::FN-TO-READVISE IL:JOIN (XCL:READVISE-FUNCTION XCL::FN :IN XCL::IN-FN))) ((AND (CONSP XCL::IN-FN) (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))) (IL:FOR XCL::FN IL:IN XCL::IN-FN IL:JOIN (XCL:READVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::FN))) (T (XCL:UNADVISE-FUNCTION XCL::FN-TO-READVISE :IN XCL::IN-FN :NO-ERROR T) (IF XCL::IN-FN (FINISH-ADVISING XCL::FN-TO-READVISE XCL::EXECUTABLE-TO-READVISE XCL::IN-FN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)) (FINISH-ADVISING XCL::FN-TO-READVISE XCL::EXECUTABLE-TO-READVISE))))))
+
+(DEFUN UNADVISE-FROM-RESTORE-CALLS (FROM TO FN) (LET ((ENTRY (FIND-IF (FUNCTION (LAMBDA (ENTRY) (AND (CONSP ENTRY) (EQ (FIRST ENTRY) FROM) (EQ (THIRD ENTRY) FN)))) IL:ADVISEDFNS))) (ASSERT (NOT (NULL ENTRY)) NIL "BUG: Inconsistency in SI::UNADVISE-FROM-RESTORE-CALLS") (FINISH-UNADVISING ENTRY TO) (FORMAT *TERMINAL-IO* "~S unadvised.~%" ENTRY)))
+
+(DEFUN FINISH-ADVISING (FN-TO-ADVISE EXECUTABLE-TO-ADVISE &OPTIONAL IN-FN EXECUTABLE-TO-ADVISE-IN) (COND ((NULL IN-FN) (LET* ((ALREADY-ADVISED? (MEMBER FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQ))) (ORIGINAL (IF ALREADY-ADVISED? (GET EXECUTABLE-TO-ADVISE-IN (QUOTE IL:ADVISED)) (LET ((*PRINT-CASE* :UPCASE)) (MAKE-SYMBOL (FORMAT NIL "Original ~A" EXECUTABLE-TO-ADVISE)))))) (IL:* IL:|;;| "Adjust the database of advice for this function.") (WHEN (NOT ALREADY-ADVISED?) (IL:PUTD ORIGINAL (IL:GETD EXECUTABLE-TO-ADVISE) T)) (IL:PUTD EXECUTABLE-TO-ADVISE (COMPILE NIL (CREATE-ADVISED-DEFINITION EXECUTABLE-TO-ADVISE ORIGINAL FN-TO-ADVISE))) (WHEN (NOT ALREADY-ADVISED?) (SETF (GET EXECUTABLE-TO-ADVISE (QUOTE IL:ADVISED)) ORIGINAL)) (IL:* IL:|;;| "These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE FN-TO-ADVISE *UNADVISED-FNS* :TEST (QUOTE EQUAL))) (SETQ IL:ADVISEDFNS (IL:* IL:\; "Move FN-TO-ADVISE to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS FN-TO-ADVISE (DELETE FN-TO-ADVISE IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:MARKASCHANGED FN-TO-ADVISE (QUOTE IL:ADVICE)) (LIST FN-TO-ADVISE))) (T (LET* ((ADVICE-NAME (IL:BQUOTE ((IL:\\\, FN-TO-ADVISE) :IN (IL:\\\, IN-FN)))) (ALREADY-ADVISED? (MEMBER ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) MIDDLE-MAN) (IL:* IL:|;;| "Create a middle-man for this request.  If one has already been created, use it.") (SETQ MIDDLE-MAN (OR (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (SETF (GET-ADVICE-MIDDLE-MAN ADVICE-NAME) (CONSTRUCT-MIDDLE-MAN EXECUTABLE-TO-ADVISE EXECUTABLE-TO-ADVISE-IN)))) (IL:* IL:|;;| "Give the middle-man the new advised definition.") (IL:PUTD MIDDLE-MAN (COMPILE NIL (CREATE-ADVISED-DEFINITION EXECUTABLE-TO-ADVISE EXECUTABLE-TO-ADVISE ADVICE-NAME))) (WHEN (NOT ALREADY-ADVISED?) (IL:* IL:|;;| "Redirect any calls to FN-TO-ADVISE in IN-FN to call the middle-man.") (CHANGE-CALLS EXECUTABLE-TO-ADVISE MIDDLE-MAN EXECUTABLE-TO-ADVISE-IN (QUOTE UNADVISE-FROM-RESTORE-CALLS))) (IL:* IL:|;;| "Save a trail of information. These are outside the WHEN because COMPILE calls VIRGINFN, which may unadvise the function.") (SETQ *UNADVISED-FNS* (DELETE ADVICE-NAME *UNADVISED-FNS* :TEST (QUOTE EQUAL))) (SETQ IL:ADVISEDFNS (IL:* IL:\; "Move ADVICE-NAME to the front of IL:ADVISEDFNS if there already, else just add to front.") (CONS ADVICE-NAME (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)))) (IL:MARKASCHANGED ADVICE-NAME (QUOTE IL:ADVICE)) (LIST ADVICE-NAME)))))
+
+(DEFUN FINISH-UNADVISING (ADVICE-NAME MIDDLE-MAN) (SETQ IL:ADVISEDFNS (DELETE ADVICE-NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (PUSH ADVICE-NAME *UNADVISED-FNS*))
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "The advice database.")

+
+
+(DEFVAR *ADVICE-HASH-TABLE* (MAKE-HASH-TABLE :TEST (QUOTE EQUAL)) (IL:* IL:|;;;| "Hash-table mapping either a function name or a list in the form (FOO :IN BAR) to a pair (advice . middle-man)."))
+
+(DEFUN ADD-ADVICE (NAME WHEN PRIORITY FORM) (IL:* IL:|;;;| "Advice is stored on the hash table SI::*ADVICE-HASH-TABLE*.  It is actually stored as a cons whose CAR is the advice and CDR is the middle-man name (for advice of the type (FOO :IN BAR)).") (LET* ((OLD-ADVICE (GETHASH NAME *ADVICE-HASH-TABLE*)) (ADVICE (IF (NULL OLD-ADVICE) (MAKE-ADVICE) (CAR OLD-ADVICE)))) (ECASE WHEN (:BEFORE (SETF (ADVICE-BEFORE ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-BEFORE ADVICE)))) (:AFTER (SETF (ADVICE-AFTER ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AFTER ADVICE)))) (:AROUND (SETF (ADVICE-AROUND ADVICE) (INSERT-ADVICE-FORM FORM PRIORITY (ADVICE-AROUND ADVICE))))) (WHEN (NULL OLD-ADVICE) (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS ADVICE NIL)))))
+
+(DEFUN DELETE-ADVICE (NAME) (REMHASH NAME *ADVICE-HASH-TABLE*))
+
+(DEFUN GET-ADVICE-MIDDLE-MAN (NAME) (CDR (GETHASH NAME *ADVICE-HASH-TABLE*)))
+
+(DEFUN SET-ADVICE-MIDDLE-MAN (NAME MIDDLE-MAN) (SETF (CDR (GETHASH NAME *ADVICE-HASH-TABLE*)) MIDDLE-MAN))
+
+(DEFUN INSERT-ADVICE-FORM (FORM PRIORITY ENTRY-LIST) (IL:* IL:|;;;| "Insert the new advice FORM into ENTRY-LIST using PRIORITY as a specification of where in that list to put it. If an equalish piece of advice already exists, remove it first.") (LET ((ENTRY (LIST PRIORITY FORM))) (SETF ENTRY-LIST (LABELS ((EQUALISH (X Y) (IL:* IL:|;;| "EQUALP, but don't ignore case in strings.") (TYPECASE X (SYMBOL (EQ X Y)) (CONS (AND (CONSP Y) (EQUALISH (CAR X) (CAR Y)) (EQUALISH (CDR X) (CDR Y)))) (NUMBER (AND (NUMBERP Y) (= X Y))) (CHARACTER (AND (CHARACTERP Y) (CHAR= X Y))) (STRING (AND (STRINGP Y) (STRING= X Y))) (PATHNAME (AND (PATHNAMEP Y) (IL:%PATHNAME-EQUAL X Y))) (VECTOR (AND (VECTORP Y) (LET ((SX (LENGTH X))) (AND (EQL SX (LENGTH Y)) (DOTIMES (I SX T) (IF (NOT (EQUALISH (AREF X I) (AREF Y I))) (RETURN NIL))))))) (ARRAY (AND (ARRAYP Y) (EQUAL (ARRAY-DIMENSIONS X) (ARRAY-DIMENSIONS Y)) (LET ((FX (IL:%FLATTEN-ARRAY X)) (FY (IL:%FLATTEN-ARRAY Y))) (DOTIMES (I (ARRAY-TOTAL-SIZE X) T) (IF (NOT (EQUALISH (AREF FX I) (AREF FY I))) (RETURN NIL)))))) (T (IL:* IL:|;;| "so that datatypes will be properly compared") (OR (EQ X Y) (LET ((TYPENAME (IL:TYPENAME X))) (AND (EQ TYPENAME (IL:TYPENAME Y)) (LET ((DESCRIPTORS (IL:GETDESCRIPTORS TYPENAME))) (IF DESCRIPTORS (IL:FOR FIELD IL:IN DESCRIPTORS IL:ALWAYS (EQUALISH (IL:FFETCHFIELD FIELD X) (IL:FFETCHFIELD FIELD Y)))))))))))) (DELETE-IF (FUNCTION (LAMBDA (OLD-ENTRY) (XCL:DESTRUCTURING-BIND (OLD-PRIORITY OLD-FORM) OLD-ENTRY (AND (EQUAL PRIORITY OLD-PRIORITY) (EQUALISH FORM OLD-FORM))))) ENTRY-LIST))) (COND ((NULL ENTRY-LIST) (LIST ENTRY)) ((EQ PRIORITY :FIRST) (CONS ENTRY ENTRY-LIST)) ((EQ PRIORITY :LAST) (NCONC ENTRY-LIST (LIST ENTRY))) (T (IL:* IL:\; "PRIORITY is a command to the old TTY Editor.") (UNLESS (AND (CONSP PRIORITY) (MEMBER (CAR PRIORITY) (QUOTE (IL:BEFORE IL:AFTER)))) (ERROR "Malformed priority argument to ADVISE: ~S" PRIORITY)) (XCL:CONDITION-CASE (IL:EDITE ENTRY-LIST (IL:BQUOTE ((IL:LC (IL:\\\,@ (CDR PRIORITY))) (IL:BELOW IL:^) ((IL:\\\, (CAR PRIORITY)) (IL:\\\, ENTRY))))) (ERROR (C) (ERROR "Error from EDITE during insertion of new advice:~%  ~A~%" C))) ENTRY-LIST))))
+
+(DEFSETF GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN)
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "Hacking the actual advice forms.")

+
+
+(DEFUN CREATE-ADVISED-DEFINITION (ADVISED-FN FN-TO-CALL ADVICE-NAME) (MULTIPLE-VALUE-BIND (LAMBDA-CAR ARG-LIST CALLING-FORM) (FUNCTION-WRAPPER-INFO ADVISED-FN FN-TO-CALL) (LET* ((ADVICE (CAR (GETHASH ADVICE-NAME *ADVICE-HASH-TABLE*))) (BEFORE-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-BEFORE ADVICE))) (AFTER-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-AFTER ADVICE))) (AROUND-FORMS (MAPCAR (QUOTE SECOND) (ADVICE-AROUND ADVICE))) (BODY-FORM (MAKE-AROUND-BODY CALLING-FORM AROUND-FORMS))) (IL:BQUOTE ((IL:\\\, LAMBDA-CAR) (IL:\\\, (IF (EQ LAMBDA-CAR (QUOTE LAMBDA)) (QUOTE (&REST XCL:ARGLIST)) ARG-LIST)) (IL:\\\,@ (AND ARG-LIST (MEMBER LAMBDA-CAR (QUOTE (IL:LAMBDA IL:NLAMBDA))) (IL:BQUOTE ((DECLARE (SPECIAL (IL:\\\,@ (IF (SYMBOLP ARG-LIST) (LIST ARG-LIST) ARG-LIST)))))))) (IL:\\CALLME (QUOTE (:ADVISED (IL:\\\, ADVICE-NAME)))) (BLOCK NIL (XCL:DESTRUCTURING-BIND (IL:!VALUE . IL:!OTHER-VALUES) (MULTIPLE-VALUE-LIST (PROGN (IL:\\\,@ BEFORE-FORMS) (IL:\\\, BODY-FORM))) (IL:\\\,@ AFTER-FORMS) (APPLY (QUOTE VALUES) IL:!VALUE IL:!OTHER-VALUES))))))))
+
+(DEFUN MAKE-AROUND-BODY (CALLING-FORM AROUND-FORMS) (REDUCE (FUNCTION (LAMBDA (CURRENT-BODY NEXT-AROUND-FORM) (LET ((CANONICALIZED-AROUND-FORM (SUBST (QUOTE (XCL:INNER)) (QUOTE IL:*) NEXT-AROUND-FORM))) (IL:BQUOTE (MACROLET ((XCL:INNER NIL (QUOTE (IL:\\\, CURRENT-BODY)))) (IL:\\\, CANONICALIZED-AROUND-FORM)))))) AROUND-FORMS :INITIAL-VALUE CALLING-FORM))
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "Dealing with the File Manager")

+
+(IL:PUTDEF (QUOTE IL:ADVICE) (QUOTE IL:FILEPKGCOMS) (QUOTE ((IL:COM IL:MACRO (IL:X (IL:P IL:* (ADVICE-FILE-DEFINITIONS (QUOTE IL:X) NIL))) IL:CONTENTS IL:NILL IL:ADD ADVICE-ADDTOCOM) (TYPE IL:DESCRIPTION "advice" IL:NEWCOM ADVICE-NEWCOM IL:GETDEF ADVICE-GETDEF IL:DELDEF ADVICE-DELDEF IL:PUTDEF ADVICE-PUTDEF IL:HASDEF ADVICE-HASDEF)))
+)
+(IL:PUTDEF (QUOTE IL:ADVISE) (QUOTE IL:FILEPKGCOMS) (QUOTE ((IL:COM IL:MACRO (IL:X (IL:P IL:* (ADVICE-FILE-DEFINITIONS (QUOTE IL:X) T))) IL:CONTENTS ADVISE-CONTENTS IL:ADD ADVICE-ADDTOCOM)))
+)
+
+(DEFUN XCL:REINSTALL-ADVICE (XCL::NAME &KEY XCL::BEFORE XCL::AFTER XCL::AROUND) (IL:FOR XCL::ADVICE IL:IN XCL::BEFORE IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :BEFORE XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AFTER IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AFTER XCL::PRIORITY XCL::FORM))) (IL:FOR XCL::ADVICE IL:IN XCL::AROUND IL:DO (XCL:DESTRUCTURING-BIND (XCL::PRIORITY XCL::FORM) XCL::ADVICE (ADD-ADVICE XCL::NAME :AROUND XCL::PRIORITY XCL::FORM))))
+
+(DEFUN ADVICE-GETDEF (NAME TYPE OPTIONS) (LET ((ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (AND ADVICE (APPEND (IL:FOR ENTRY IL:IN (ADVICE-BEFORE ADVICE) IL:COLLECT (CONS (QUOTE :BEFORE) (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AFTER ADVICE) IL:COLLECT (CONS (QUOTE :AFTER) (COPY-TREE ENTRY))) (IL:FOR ENTRY IL:IN (ADVICE-AROUND ADVICE) IL:COLLECT (CONS (QUOTE :AROUND) (COPY-TREE ENTRY)))))))
+
+(DEFUN ADVICE-PUTDEF (NAME TYPE DEFINITION) (LET ((CANONICAL-DEFN (IL:FOR ENTRY IL:IN DEFINITION IL:COLLECT (LIST (CANONICALIZE-ADVICE-WHEN-SPEC (CAR ENTRY)) (CANONICALIZE-ADVICE-WHERE-SPEC (COPY-TREE (CADR ENTRY))) (COPY-TREE (CADDR ENTRY))))) (CURRENT-ADVICE (OR (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)) (CAR (SETF (GETHASH NAME *ADVICE-HASH-TABLE*) (CONS (MAKE-ADVICE) NIL)))))) (SETF (ADVICE-BEFORE CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :BEFORE) IL:COLLECT ENTRY))) (SETF (ADVICE-AFTER CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AFTER) IL:COLLECT ENTRY))) (SETF (ADVICE-AROUND CURRENT-ADVICE) (MAPCAR (FUNCTION REST) (IL:FOR ENTRY IL:IN CANONICAL-DEFN IL:WHEN (EQ (CAR ENTRY) :AROUND) IL:COLLECT ENTRY))) (IF (CONSP NAME) (XCL:READVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:READVISE-FUNCTION NAME))))
+
+(DEFUN ADVICE-DELDEF (NAME TYPE) (DECLARE (IGNORE TYPE)) (WHEN (MEMBER NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL)) (IF (CONSP NAME) (XCL:UNADVISE-FUNCTION (FIRST NAME) :IN (THIRD NAME)) (XCL:UNADVISE-FUNCTION NAME)) (FORMAT *TERMINAL-IO* "~S unadvised." NAME)) (REMHASH NAME *ADVICE-HASH-TABLE*))
+
+(DEFUN ADVICE-HASDEF (NAME TYPE SOURCE) (AND (GETHASH NAME *ADVICE-HASH-TABLE*) (OR NAME T)))
+
+(DEFUN ADVICE-NEWCOM (NAME TYPE LISTNAME FILE) (IL:* IL:|;;;| "If you make a new com for ADVICE, you should make an ADVISE command.") (IL:DEFAULTMAKENEWCOM NAME (QUOTE IL:ADVISE) LISTNAME FILE))
+
+(DEFUN ADVICE-FILE-DEFINITIONS (NAMES READVISE?) (IL:* IL:|;;;| "READVISE? is true for the File Manager command ADVISE and false for the command ADVICE.  For ADVISE, we want to emit a form to readvise the named functions after reinstalling the advice.") (LET ((REAL-NAMES NIL)) (IL:BQUOTE ((IL:\\\,@ (IL:FOR FN IL:IN NAMES IL:COLLECT (LET* ((NAME (IL:IF (CONSP FN) IL:THEN (ASSERT (AND (EQ (SECOND FN) :IN) (= 3 (LENGTH FN))) NIL "~S should be of the form (FOO :IN BAR)" FN) FN IL:ELSE (LET ((NAME (CANONICALIZE-ADVICE-SYMBOL FN)) (OLD-ADVICE (GET FN (QUOTE IL:READVICE)))) (WHEN OLD-ADVICE (ADD-OLD-STYLE-ADVICE NAME OLD-ADVICE) (REMPROP FN (QUOTE IL:READVICE))) NAME))) (ADVICE (CAR (GETHASH NAME *ADVICE-HASH-TABLE*)))) (ASSERT (NOT (NULL ADVICE)) NIL "Can't find advice for ~S" NAME) (PUSH NAME REAL-NAMES) (IL:BQUOTE (XCL:REINSTALL-ADVICE (QUOTE (IL:\\\, NAME)) (IL:\\\,@ (AND (ADVICE-BEFORE ADVICE) (IL:BQUOTE (:BEFORE (QUOTE (IL:\\\, (ADVICE-BEFORE ADVICE))))))) (IL:\\\,@ (AND (ADVICE-AFTER ADVICE) (IL:BQUOTE (:AFTER (QUOTE (IL:\\\, (ADVICE-AFTER ADVICE))))))) (IL:\\\,@ (AND (ADVICE-AROUND ADVICE) (IL:BQUOTE (:AROUND (QUOTE (IL:\\\, (ADVICE-AROUND ADVICE)))))))))))) (IL:\\\,@ (AND READVISE? (IL:BQUOTE ((IL:READVISE (IL:\\\,@ (REVERSE REAL-NAMES)))))))))))
+
+(DEFUN ADVISE-CONTENTS (COM NAME TYPE) (AND (EQ TYPE (QUOTE IL:ADVICE)) (COND ((NULL NAME) (IL:* IL:\; "Return a list of the ADVICE's in the given COM.") (CDR COM)) ((EQ NAME (QUOTE T)) (IL:* IL:\; "Return T if there are ANY ADVICE's in the given COM.") (NOT (NULL (CDR COM)))) ((OR (SYMBOLP NAME) (= (LENGTH NAME) 3) (EQ (SECOND NAME) :IN)) (IL:* IL:\; "Return T iff an ADVICE named NAME in the given COM.") (AND (MEMBER NAME (CDR COM) :TEST (QUOTE EQUAL)) T)) (T (IL:* IL:\; "NAME is a list of names.  Return the intersection of that list with the ADVICE's in the given COM.") (INTERSECTION NAME (CDR COM) :TEST (QUOTE EQUAL))))))
+
+(DEFUN ADVICE-ADDTOCOM (COM NAME TYPE NEAR) (IL:* IL:|;;;| "This is the ADD method for both of the ADVICE and ADVISE commands.") (IL:* IL:|;;;| "Add the given name only if the type is ADVICE.  Also, add it to ADVICE commands only if a NEAR was specified.  We want to normally create only ADVISE commands.  If the user really wants an ADVICE command, they'll have to create it themselves.") (AND (EQ TYPE (QUOTE IL:ADVICE)) (OR (EQ (CAR COM) (QUOTE IL:ADVISE)) (NOT (NULL NEAR))) (IL:ADDTOCOM1 COM NAME NEAR NIL)))
+
+(IL:PUTPROPS IL:ADVISED IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;| "")

+
+
+
+
+(IL:* IL:|;;| "Dealing with old-style advice")

+
+
+(DEFUN IL:READVISE1 (IL:FN) (FLET ((IL:READVISE-ENTRY (IL:ENTRY) (IL:IF (IL:LISTP IL:ENTRY) IL:THEN (XCL:READVISE-FUNCTION (FIRST IL:ENTRY) :IN (THIRD IL:ENTRY)) IL:ELSE (XCL:READVISE-FUNCTION IL:ENTRY)))) (IL:IF (IL:LISTP IL:FN) IL:THEN (ASSERT (IL:STRING.EQUAL (SECOND IL:FN) "IN") NIL "~S should be in the form (FOO IN BAR).~%" IL:FN) (IL:READVISE-ENTRY IL:FN) IL:ELSE (LET ((IL:NAME (CANONICALIZE-ADVICE-SYMBOL IL:FN)) (IL:OLD-ADVICE (GET IL:FN (QUOTE IL:READVICE)))) (IL:IF IL:OLD-ADVICE IL:THEN (ADD-OLD-STYLE-ADVICE IL:NAME IL:OLD-ADVICE) (REMPROP IL:FN (QUOTE IL:READVICE))) (IL:READVISE-ENTRY IL:NAME)))))
+
+(DEFUN ADD-OLD-STYLE-ADVICE (NAME OLD-ADVICE) (IL:* IL:|;;;| "OLD-ADVICE should the value of the READVICE property of some symbol.  Note that the CAR of that value is the old middle-man used for -IN- advice.  Thus, we take the CDR below.") (WHEN (NOT (MEMBER NAME IL:ADVISEDFNS :TEST (QUOTE EQUAL))) (DELETE-ADVICE NAME)) (IL:FOR ADVICE IL:IN (CDR OLD-ADVICE) IL:DO (XCL:DESTRUCTURING-BIND (WHEN WHERE WHAT) ADVICE (IL:* IL:|;;| "Translate Interlisp names to the new standard.") (ADD-ADVICE NAME (CANONICALIZE-ADVICE-WHEN-SPEC WHEN) (CANONICALIZE-ADVICE-WHERE-SPEC WHERE) WHAT))))
+
+(DEFUN CANONICALIZE-ADVICE-SYMBOL (SYMBOL) (LET ((IN-POS (IL:STRPOS "-IN-" SYMBOL))) (IF (NULL IN-POS) SYMBOL (LIST (IL:SUBATOM SYMBOL 1 (1- IN-POS)) :IN (IL:SUBATOM SYMBOL (+ IN-POS 4) NIL)))))
+
+(DEFUN CANONICALIZE-ADVICE-WHEN-SPEC (SPEC) (IF (NULL SPEC) (QUOTE :BEFORE) (INTERN (STRING SPEC) "KEYWORD")))
+
+(DEFUN CANONICALIZE-ADVICE-WHERE-SPEC (SPEC) (CASE SPEC ((NIL LAST IL:BOTTOM IL:END :LAST) (QUOTE :LAST)) ((IL:TOP IL:FIRST :FIRST) (QUOTE :FIRST)) (T (IF (CONSP SPEC) SPEC (ERROR "Illegal WHERE specification to ADVISE: ~S" SPEC)))))
+
+(XCL:DEF-DEFINE-TYPE XCL:ADVISED-FUNCTIONS "Advised function definitions")
+
+(XCL:DEFDEFINER (XCL:DEFADVICE (:PROTOTYPE (LAMBDA (XCL::NAME) (IL:BQUOTE (XCL:DEFADVICE (IL:\\\, XCL::NAME) "advice"))))) XCL:ADVISED-FUNCTIONS (XCL::NAME &BODY XCL::ADVICE-FORMS) (IL:BQUOTE (PROGN (IL:\\\,. (XCL:WITH-COLLECTION (DOLIST (XCL::ADVICE XCL::ADVICE-FORMS) (XCL:COLLECT (XCL:DESTRUCTURING-BIND (XCL::FN-TO-ADVISE XCL::FORM &KEY XCL::IN WHEN XCL::PRIORITY) XCL::ADVICE (IL:BQUOTE (XCL:ADVISE-FUNCTION (QUOTE (IL:\\\, XCL::FN-TO-ADVISE)) (QUOTE (IL:\\\, XCL::FORM)) (IL:\\\,@ (AND XCL::IN (IL:BQUOTE (:IN (QUOTE (IL:\\\, XCL::IN)))))) (IL:\\\,@ (AND WHEN (IL:BQUOTE (:WHEN (IL:\\\, WHEN))))) (IL:\\\,@ (AND XCL::PRIORITY (IL:BQUOTE (:PRIORITY (IL:\\\, XCL::PRIORITY)))))))))))))))
+
+
+
+(IL:* IL:|;;| 
+"Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package."
+)

+
+
+(IL:PUTPROPS IL:ADVISE IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "SYSTEM"))
+
+(IL:PUTPROPS IL:ADVISE IL:FILETYPE :COMPILE-FILE)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA IL:READVISE IL:UNADVISE)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA IL:ADVISE)
+)
+(IL:PRETTYCOMPRINT IL:ADVISECOMS)
+
+(IL:RPAQQ IL:ADVISECOMS ((IL:STRUCTURES ADVICE) (IL:VARIABLES IL:ADVISEDFNS *UNADVISED-FNS*) (IL:* IL:|;;| "") (IL:* IL:|;;| "Interlisp entry points.") (IL:FNS IL:ADVISE IL:UNADVISE IL:READVISE) (IL:PROP IL:ARGNAMES IL:ADVISE) (IL:* IL:|;;| "") (IL:* IL:|;;| "XCL entry points.") (IL:FUNCTIONS XCL:ADVISE-FUNCTION XCL:UNADVISE-FUNCTION XCL:READVISE-FUNCTION) (IL:FUNCTIONS UNADVISE-FROM-RESTORE-CALLS FINISH-ADVISING FINISH-UNADVISING) (IL:* IL:|;;| "") (IL:* IL:|;;| "The advice database.") (IL:VARIABLES *ADVICE-HASH-TABLE*) (IL:FUNCTIONS ADD-ADVICE DELETE-ADVICE GET-ADVICE-MIDDLE-MAN SET-ADVICE-MIDDLE-MAN INSERT-ADVICE-FORM) (IL:SETFS GET-ADVICE-MIDDLE-MAN) (IL:* IL:|;;| "") (IL:* IL:|;;| "Hacking the actual advice forms.") (IL:FUNCTIONS CREATE-ADVISED-DEFINITION MAKE-AROUND-BODY) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with the File Manager") (IL:FILEPKGCOMS IL:ADVICE IL:ADVISE) (IL:FUNCTIONS XCL:REINSTALL-ADVICE) (IL:FUNCTIONS ADVICE-GETDEF ADVICE-PUTDEF ADVICE-DELDEF ADVICE-HASDEF ADVICE-NEWCOM ADVICE-FILE-DEFINITIONS ADVISE-CONTENTS ADVICE-ADDTOCOM) (IL:PROP IL:PROPTYPE IL:ADVISED) (IL:* IL:|;;| "") (IL:* IL:|;;| "Dealing with old-style advice") (IL:FUNCTIONS IL:READVISE1 ADD-OLD-STYLE-ADVICE CANONICALIZE-ADVICE-SYMBOL CANONICALIZE-ADVICE-WHEN-SPEC CANONICALIZE-ADVICE-WHERE-SPEC) (IL:DEFINE-TYPES XCL:ADVISED-FUNCTIONS) (IL:FUNCTIONS XCL:DEFADVICE) (IL:* IL:|;;| "Arrange for the proper package.  Because of the DEFSTRUCT above, we must have the file dumped in the SYSTEM package.") (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:ADVISE) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA IL:ADVISE)))))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA IL:ADVISE)
+)
+(IL:PUTPROPS IL:ADVISE IL:COPYRIGHT ("Venue & Xerox Corporation" T 1978 1984 1986 1987 1988 1990 1992)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (2691 7263 (IL:ADVISE 2704 . 4833) (IL:UNADVISE 4835 . 5755) (IL:READVISE 5757 . 7261
+)))))
+IL:STOP

CLTL2/AERROR

@@ -0,0 +1,76 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "13-Mar-92 14:41:54" {DSK}<usr>local>lde>lispcore>sources>AERROR.;2
 7354   
+
+      changes to%:  (VARS AERRORCOMS)
+
+      previous date%: "16-May-90 11:58:35" {DSK}<usr>local>lde>lispcore>sources>AERROR.;1)
+
+
+(* ; "
+Copyright (c) 1982, 1983, 1986, 1987, 1988, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT AERRORCOMS)
+
+(RPAQQ AERRORCOMS ((FNS ERRORSTRING SETERRORN LISPERROR \LISPERROR \ILLEGAL.ARG \ARG.NOT.LITATOM) (EXPORT (DECLARE%: EVAL@COMPILE (VARS \ERRORMESSAGELIST) DONTCOPY (OPTIMIZERS LISPERROR))) (VARIABLES *LAST-CONDITION*) (GLOBALVARS \ERRORMESSAGELIST) (FUNCTIONS ERRM-TO-CONDITION) (PROP FILETYPE AERROR) (LOCALVARS . T)))
+(DEFINEQ
+
+(ERRORSTRING

+(LAMBDA (X) (* lmm "21-APR-80 15:46") (CAR (NTH \ERRORMESSAGELIST (ADD1 (OR (NUMBERP X) 17))))))
+
+(SETERRORN

+(LAMBDA (NUM MESS) (* amd "30-Jul-86 17:00") (CL:SETQ *LAST-CONDITION* (ERRM-TO-CONDITION NUM MESS))))
+
+(LISPERROR

+  [LAMBDA (N X CONTINUEOKFLG)
                            (* ; "Edited  1-Feb-89 09:38 by jds")

+
+    (* ;; "compiles open as call to \LISPERROR")

+
+    [COND
+       ((STRINGP N)
+
+        (* ;; "Case where LISPERROR is called with one of the %"canonical error message%" strings from the old IL implementation.  Need to translate it to a number.  THIS CODE IS STOLEN IN SPIRIT FROM THE OPTIMIZER.")

+
+        (FOR
 MSG IN
 \ERRORMESSAGELIST AS
 I FROM
 0 WHEN
 (CL:EQUAL MSG N)
+           DO
 (SETQ N I]
+    (\LISPERROR
 X N CONTINUEOKFLG])
+
+(\LISPERROR

+(LAMBDA (X N CONTINUEOKFLG) (* amd "11-Nov-86 12:09") (DECLARE (USEDFREE \INTERRUPTABLE)) (PROG NIL (SELECTQ N ((5 22) (* ; "File errors that can happen to files open for output") (* ;; "(\STOP.DRIBBLE?  X)")) NIL) (OR \INTERRUPTABLE (\MP.ERROR \MP.UNINTERRUPTABLE "Error in uninterruptable system code -- ^N to continue into error handler" X)) RET (RETURN (PROG1 (COND ((SMALLP N) (ERRORX (LIST N X))) (T (ERROR N X))) (OR CONTINUEOKFLG (GO RET))))))
+)
+
+(\ILLEGAL.ARG

+(LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ILLEGAL ARG" X)))
+
+(\ARG.NOT.LITATOM

+(LAMBDA (X) (* lmm "25-APR-80 18:02") (LISPERROR "ARG NOT LITATOM" X)))
+)
+(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ \ERRORMESSAGELIST ("SYSTEM ERROR" " " "STACK OVERFLOW" "ILLEGAL RETURN" "ARG NOT LIST" "HARD DISK ERROR" "ATTEMPT TO SET NIL OR T" "ATTEMPT TO RPLAC NIL" "UNDEFINED OR ILLEGAL GO" "FILE WON'T OPEN" "NON-NUMERIC ARG" "ATOM TOO LONG" "ATOM HASH TABLE FULL" "FILE NOT OPEN" "ARG NOT LITATOM" "! too many files open" "END OF FILE" "ERROR" "BREAK" "ILLEGAL STACK ARG" "FAULT IN EVAL" "ARRAYS FULL" "FILE SYSTEM RESOURCES EXCEEDED" "FILE NOT FOUND" "BAD SYSOUT FILE" "UNUSUAL CDR ARG LIST" "HASH TABLE FULL" "ILLEGAL ARG" "ARG NOT ARRAY" "ILLEGAL OR IMPOSSIBLE BLOCK" "STACK PTR HAS BEEN RELEASED" "STORAGE FULL" "ATTEMPT TO USE ITEM OF INCORRECT TYPE" "ILLEGAL DATA TYPE NUMBER" "DATA TYPES FULL" "ATTEMPT TO BIND NIL OR T" "! too many user interrupt characters" "! read-macro context error" "ILLEGAL READTABLE" "ILLEGAL TERMINAL TABLE" "! swapblock too big for buffer" "PROTECTION VIOLATION" "BAD FILE NAME" "USER BREAK" "UNBOUND ATOM" "UNDEFINED CAR OF FORM" "UNDEFINED FUNCTION" "CONTROL-E" "FLOATING UNDERFLOW" "FLOATING OVERFLOW" "OVERFLOW" "ARG NOT HARRAY" "TOO MANY ARGUMENTS"))
+DONTCOPY 
+
+(DEFOPTIMIZER LISPERROR (MESSAGE ARG) (BQUOTE (\LISPERROR (\, ARG) (\, (CL:IF (CL:STRINGP MESSAGE) (FOR X IN \ERRORMESSAGELIST AS I FROM 0 WHEN (CL:EQUAL X MESSAGE) DO (RETURN I) FINALLY (RETURN (HELP "Unknown error message" (LIST MESSAGE ARG)))) MESSAGE)))))
+)
+
+(* "END EXPORTED DEFINITIONS")
+
+
+(CL:DEFVAR *LAST-CONDITION* NIL "Last condition signalled. This gets rebound to itself in nested execs.")
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS \ERRORMESSAGELIST)
+)
+
+(CL:DEFUN ERRM-TO-CONDITION (NUM MESSAGE) (CL:IF (TYPEP NUM (QUOTE CONDITION)) NUM (CASE NUM (2 (* ; "STACK OVERFLOW") (MAKE-CONDITION (QUOTE STACK-OVERFLOW))) (3 (* ; "ILLEGAL RETURN") (MAKE-CONDITION (QUOTE ILLEGAL-RETURN) :TAG MESSAGE)) ((4 10 14 28 38 39 51) (* ; "ARG NOT x") (MAKE-CONDITION (QUOTE XCL:TYPE-MISMATCH) :NAME MESSAGE :VALUE MESSAGE :EXPECTED-TYPE (CL:ECASE NUM (4 (QUOTE LIST)) (10 (QUOTE CL:NUMBER)) (14 (QUOTE CL:SYMBOL)) (28 (QUOTE ARRAYP)) (38 (QUOTE READTABLEP)) (39 (QUOTE TERMTABLEP)) (51 (QUOTE CL:HASH-TABLE))))) (5 (* ; "HARD DISK ERROR") (MAKE-CONDITION (QUOTE XCL:SIMPLE-DEVICE-ERROR) :MESSAGE MESSAGE)) ((6 35) (* ; "ATTEMPT TO SET NIL, ATTEMPT TO BIND NIL OR T") (MAKE-CONDITION (QUOTE XCL:ATTEMPT-TO-CHANGE-CONSTANT) :NAME NIL)) (7 (* ; "ATTEMPT TO RPLAC NIL") (MAKE-CONDITION (QUOTE XCL:ATTEMPT-TO-RPLAC-NIL) :NAME MESSAGE)) (8 (* ; "UNDEFINED OR ILLEGAL GO") (MAKE-CONDITION (QUOTE ILLEGAL-GO) :TAG MESSAGE)) (9 (* ; "FILE WON'T OPEN") (MAKE-CONDITION (QUOTE XCL:FILE-WONT-OPEN) :PATHNAME MESSAGE)) (11 (* ; "ATOM TOO LONG") (MAKE-CONDITION (QUOTE XCL:SYMBOL-NAME-TOO-LONG))) (12 (* ; "ATOM HASH TABLE FULL") (MAKE-CONDITION (QUOTE XCL:SYMBOL-HT-FULL))) (13 (* ; "FILE NOT OPEN") (MAKE-CONDITION (QUOTE XCL:STREAM-NOT-OPEN) :STREAM MESSAGE)) (16 (* ; "END OF FILE") (MAKE-CONDITION (QUOTE END-OF-FILE) :STREAM MESSAGE)) (17 (* ; "ERROR") (MAKE-CONDITION (QUOTE INTERLISP-ERROR) :MESSAGE MESSAGE)) (19 (* ; "ILLEGAL STACK ARG") (MAKE-CONDITION (QUOTE ILLEGAL-STACK-ARG) :ARG MESSAGE)) (21 (* ; "ARRAYS FULL") (MAKE-CONDITION (QUOTE XCL:ARRAY-SPACE-FULL))) (22 (* ; "FILE SYSTEM RESOURCES EXCEEDED") (MAKE-CONDITION (QUOTE XCL:FS-RESOURCES-EXCEEDED) :PATHNAME MESSAGE)) (23 (* ; "FILE NOT FOUND") (MAKE-CONDITION (QUOTE XCL:FILE-NOT-FOUND) :PATHNAME MESSAGE)) ((25 27) (* ; "UNUSUAL CDR ARG LIST, ILLEGAL ARG") (MAKE-CONDITION (QUOTE INVALID-ARGUMENT-LIST) :ARGUMENT MESSAGE)) (26 (* ; "HASH TABLE FULL") (MAKE-CONDITION (QUOTE XCL:HASH-TABLE-FULL) :TABLE MESSAGE)) (30 (* ; "STACK PTR HAS BEEN RELEASED") (MAKE-CONDITION (QUOTE STACK-POINTER-RELEASED) :NAME MESSAGE)) (31 (* ; "STORAGE FULL") (MAKE-CONDITION (QUOTE XCL:STORAGE-EXHAUSTED))) (34 (* ; "DATA TYPES FULL") (MAKE-CONDITION (QUOTE XCL:DATA-TYPES-EXHAUSTED))) (41 (* ; "PROTECTION VIOLATION") (MAKE-CONDITION (QUOTE XCL:FS-PROTECTION-VIOLATION) :PATHNAME MESSAGE)) (42 (* ; "BAD FILE NAME") (MAKE-CONDITION (QUOTE XCL:INVALID-PATHNAME) :PATHNAME MESSAGE)) (44 (* ; "UNBOUND ATOM") (MAKE-CONDITION (QUOTE UNBOUND-VARIABLE) :NAME MESSAGE)) (45 (* ; "UNDEFINED CAR OF FORM") (MAKE-CONDITION (QUOTE UNDEFINED-CAR-OF-FORM) :FUNCTION MESSAGE)) (46 (* ; "UNDEFINED FUNCTION") (MAKE-CONDITION (QUOTE UNDEFINED-FUNCTION-IN-APPLY) :NAME (CL:FIRST MESSAGE) :ARGUMENTS (CL:SECOND MESSAGE))) (47 (* ; "CONTROL-E") (MAKE-CONDITION (QUOTE XCL:CONTROL-E-INTERRUPT))) (48 (* ; "FLOATING UNDERFLOW") (MAKE-CONDITION (QUOTE CL:FLOATING-POINT-UNDERFLOW))) (49 (* ; "FLOATING OVERFLOW") (MAKE-CONDITION (QUOTE CL:FLOATING-POINT-OVERFLOW))) (52 (* ; "TOO MANY ARGUMENTS") (MAKE-CONDITION (QUOTE TOO-MANY-ARGUMENTS) :CALLEE MESSAGE :MAXIMUM CL:CALL-ARGUMENTS-LIMIT)) (CL:OTHERWISE (CL:ERROR "Interlisp error number ~D (message: ~S) no longer supported" NUM MESSAGE)))))
+
+(PUTPROPS AERROR FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+(PUTPROPS AERROR COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1986 1987 1988 1989 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (773 2259 (ERRORSTRING 783 . 896) (SETERRORN 898 . 1015) (LISPERROR 1017 . 1604) (
+\LISPERROR 1606 . 2075) (\ILLEGAL.ARG 2077 . 2162) (\ARG.NOT.LITATOM 2164 . 2257)))))
+STOP

CLTL2/BOOTSTRAP

@@ -0,0 +1,864 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "12-Oct-93 15:20:15" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BOOTSTRAP.;1"
 41500  
+
+      changes to%:  (VARS BOOTSTRAPCOMS)
+                    (FNS \LOAD-STREAM)
+
+      previous date%: " 2-Nov-92 04:15:40" "{Pele:mv:envos}<LispCore>Sources>BOOTSTRAP.;4")
+
+
+(* ; "
+Copyright (c) 1983, 1984, 1985, 1986, 1987, 1988, 1989, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT BOOTSTRAPCOMS)
+
+(RPAQQ BOOTSTRAPCOMS

+       [(COMS                                                (* ; "Some basic fns.  Note that several are redefined later.  E.g., RPAQQ et al real definitions are on UNDO")

+              (FNS GETPROP SETATOMVAL RPAQQ RPAQ RPAQ? MOVD MOVD? SELECTQ SELECTQ1 NCONC1 PUTPROP 
+                   PROPNAMES ADDPROP REMPROP MEMB CLOSEF?))
+        (COMS                                                (* ; 
+
                                          "Need these in order to load even compiled files SYSLOAD")

+              (FNS LOAD \LOAD-STREAM FILECREATED FILECREATED1 PRETTYCOMPRINT BOOTSTRAP-NAMEFIELD 
+                   PUTPROPS DECLARE%: DECLARE%:1 ROOTFILENAME DEFINE-FILE-INFO \DO-DEFINE-FILE-INFO))
+        (INITVARS (EOLCHARCODE (CHCON1 "
+"))
+               (PRETTYHEADER)
+               (DWIMFLG)
+               (UPDATEMAPFLG)
+               (DFNFLG)
+               (ADDSPELLFLG)
+               (BUILDMAPFLG)
+               (FILEPKGFLG)
+               (SYSFILES)
+               (NOTCOMPILEDFILES)
+               (RESETVARSLST)
+               [LOADPARAMETERS '((SEQUENTIAL T]
+               (LISPXHIST)
+               (LISPXPRINTFLG T)
+               (PRETTYHEADER "File created ")
+               (LOAD-VERBOSE-STREAM T)
+               (BELLS '"")
+               (LOADOPTIONS '(SYSLOAD NIL T PROP ALLPROP))
+               (PRETTYDEFMACROS NIL)
+               (PRETTYTYPELST NIL)
+               (FILEPKGTYPES NIL))
+        (ADDVARS (LOADEDFILELST))
+        (GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
+        (DECLARE%: DONTEVAL@LOAD DOCOPY [P [MAPC '((PUTD . /PUTD)
+                                                   (PUTPROP . /PUTPROP)
+                                                   (PUTPROP . PUT)
+                                                   (PUTPROP . SAVEPUT)
+                                                   (ADDPROP . /ADDPROP)
+                                                   (PUT . /PUT)
+                                                   (PRIN1 . LISPXPRIN1)
+                                                   (PRIN2 . LISPXPRIN2)
+                                                   (PRINT . LISPXPRINT)
+                                                   (TERPRI . LISPXTERPRI)
+                                                   (SPACES . LISPXSPACES)
+                                                   (GETPROP . GETP)
+                                                   (SET . SAVESET)
+                                                   (SET . /SET)
+                                                   (NILL . MISSPELLED?)
+                                                   (SETTOPVAL . /SETTOPVAL)
+                                                   (BOOTSTRAP-NAMEFIELD . NAMEFIELD)
+                                                   (BOOTSTRAP-NAMEFIELD . COMSNAME)
+                                                   (NILL . RESETRESTORE))
+                                                 (FUNCTION (LAMBDA (X)
+                                                                  (OR (CCODEP (CDR X))
+                                                                      (MOVD (CAR X)
+                                                                            (CDR X)
+                                                                            NIL T]
+                                           (AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
+                                                (PUTD 'BOOTSTRAP-NAMEFIELD]
+               (P (RADIX 10)))
+        (DECLARE%: DOEVAL@COMPILE DONTCOPY                   (* ; "eventually imported from FASL")

+               (CONSTANTS FASL:SIGNATURE))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
+                      (NLAML PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
+                      (LAMA])
+
+
+
+(* ; 
+"Some basic fns.  Note that several are redefined later.  E.g., RPAQQ et al real definitions are on UNDO"
+)

+
+(DEFINEQ
+
+(GETPROP

+  [LAMBDA (ATM PROP)
                                     (* lmm " 5-SEP-83 22:29")

+                                                             (* ; "Used to be called GETP")

+
+    (AND (LITATOM ATM)
+         (PROG ((PLIST (GETPROPLIST ATM)))
+           LP  [COND
+                  ((OR (NLISTP PLIST)
+                       (NLISTP (CDR PLIST)))
+                   (RETURN NIL))
+                  ((EQ (CAR PLIST)
+                       PROP)
+                   (RETURN (CADR PLIST]
+               (SETQ PLIST (CDDR PLIST))
+               (GO LP])
+
+(SETATOMVAL

+  [LAMBDA (X Y)
                                          (* bvm%: "29-Sep-86 16:14")

+    (SETTOPVAL X Y])
+
+(RPAQQ

+  [NLAMBDA (X Y)
+    (SETATOMVAL
 X Y])
+
+(RPAQ

+  [NLAMBDA (RPAQX RPAQY)
                                 (* lmm "23-JUL-83 16:10")

+                                                             (* ; 
+
                                               "RPAQ and RPAQQ are used by PRETTYDEF to save VARS.")

+
+    (SETTOPVAL RPAQX (EVAL RPAQY])
+
+(RPAQ?

+  [NLAMBDA (RPAQX RPAQY)
                                 (* lmm "23-JUL-83 16:12")

+                                                             (* ; 
+
                                             "RPAQ?  and RPAQQ are used by PRETTYDEF to save VARS.")

+
+    (OR (NEQ (GETTOPVAL RPAQX)
+             'NOBIND)
+        (SETTOPVAL RPAQX (EVAL RPAQY])
+
+(MOVD

+  [LAMBDA (FROM
 TO
 COPYFLG DONTCOPY)
  (* ; 
+
                                                "Edited  2-Nov-92 03:50 by sybalsky:mv:envos")

+    (COND
+       ((AND DONTCOPY (NULL COPYFLG))
+
+        (* ;; "He really wants NO copy made, not a renamed version.")

+
+        (* ;; 
+
      "This is like MOVD, but absolutely no consing is done, frame names are not changed, etc.")

+
+        (LET ((FROMCELL (fetch
 (LITATOM DEFINITIONCELL) of
 FROM))
+              (TOCELL (fetch
 (LITATOM DEFINITIONCELL) of
 TO)))
+             (UNINTERRUPTABLY
+                 (replace
 (DEFINITIONCELL DEFPOINTER) of
 TOCELL with
 (fetch

+                                                                                  (DEFINITIONCELL
+                                                                                   DEFPOINTER)
+                                                                                    of
 FROMCELL))
+                 (replace
 (DEFINITIONCELL DEFCELLFLAGS) of
 TOCELL with

+                                                                          (fetch
 (DEFINITIONCELL
+                                                                                      DEFCELLFLAGS)
+                                                                             of
 FROMCELL))
+                 (replace
 (DEFINITIONCELL AUXDEFCELLFLAGS) of
 TOCELL
+                    with
 (fetch
 (DEFINITIONCELL AUXDEFCELLFLAGS) of
 FROMCELL))
+                 TO)))
+       (T (LET [(NEWFLG (NULL (GETD TO]
+               (PUTD TO (COND
+                           (COPYFLG (COPY (VIRGINFN FROM)))
+                           (T (GETD FROM)))
+                     DONTCOPY)
+               (AND FILEPKGFLG (EXPRP TO)
+                    (MARKASCHANGED TO 'FNS NEWFLG))
+               TO])
+
+(MOVD?

+  [LAMBDA (FROM
 TO
 COPYFLG DONTCOPY)
             (* bvm%: "10-Jul-85 13:00")

+    (* ;; "Like MOVD but only does it if TO is not defined.")

+
+    (COND
+       ((NULL (GETD TO))
+        (PUTD TO (COND
+                    (COPYFLG (COPY (VIRGINFN FROM)))
+                    (T (GETD FROM)))
+              DONTCOPY)
+        (AND FILEPKGFLG (EXPRP TO)
+             (MARKASCHANGED TO 'FNS T))
+        TO])
+
+(SELECTQ

+  [NLAMBDA SELCQ
+    (APPLY 'PROGN (SELECTQ1
 (EVAL (CAR SELCQ)
+                                      'SELECTQ)
+                         (CDR SELCQ))
+           'SELECTQ])
+
+(SELECTQ1

+  [LAMBDA (M L)
+    (PROG (C)
+      LP  (SETQ C L)
+          [COND
+             ((NULL (SETQ L (CDR L)))
+              (RETURN C))
+             ([OR (EQ (CAR (SETQ C (CAR C)))
+                      M)
+                  (AND (LISTP (CAR C))
+                       (FMEMB M (CAR C]
+              (RETURN (CDR C]
+          (GO LP])
+
+(NCONC1

+  [LAMBDA (LST X)
+          (* included in wtmisc so can make the call to nconc be linked.
+
        so that user can then break on nconc.)

+
+    (NCONC LST (FRPLACD (CONS X LST])
+
+(PUTPROP

+  [LAMBDA (ATM PROP VAL)
                                 (* ; "Edited 28-May-87 09:16 by jop")

+
+    (* ;; "Included because it must be defined before the MOVD's in BOOTSTRAPCOMS that initialize /PUTPROP are executed.")

+
+    [COND
+       ((NOT (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0)
+      LP  (COND
+             ((NLISTP X)
+              (COND
+                 ((AND (NULL X)
+                       X0)                                   (* ; 
+
                "typical case.  property list ran out on an even parity position.  e.g.  (A B C D)")

+
+                  (FRPLACD (CDR X0)
+                         (LIST PROP VAL))
+                  (RETURN VAL)))
+              (* ;; "propety list was initially NIL or a non-list, or else it ended in a non-list following an even parity position, e.g.  (A B  . C) fall through and add new property at beginning")

+
+              )
+             ((NLISTP (CDR X))
+              (* ;; "property list runs out on an odd parity, or ends in an odd list following an odd parity, e.g.  (A B C) or (A B C  . D) fall through and add at beginning")

+
+              )
+             ((EQ (CAR X)
+                  PROP)
+              (FRPLACA (CDR X)
+                     VAL)
+              (RETURN VAL))
+             (T (SETQ X (CDDR (SETQ X0 X)))
+                (GO LP)))
+          [SETPROPLIST ATM (CONS PROP (CONS VAL (GETPROPLIST ATM]
+          (RETURN VAL])
+
+(PROPNAMES

+  [LAMBDA (ATM)
                                          (* wt%: " 3-AUG-78 01:23")

+    (MAPLIST (GETPROPLIST ATM)
+           (FUNCTION CAR)
+           (FUNCTION CDDR])
+
+(ADDPROP

+  [LAMBDA (ATM PROP NEW FLG)                                 (* ; 
+
                       "If FLG is T, NEW is consed onto the front, otherwise NCONCED onto the end.")

+                                                             (* ; "Value is new PROP value.")

+
+    [COND
+       [(NULL ATM)
+        (ERRORX (LIST 7 (LIST PROP NEW]
+       ((NOT (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0)
+      LP  (COND
+             ((NLISTP X)
+              (COND
+                 ((AND (NULL X)
+                       X0)                                   (* ; 
+
                                 "typical case.  property list ran out on an even parity position.")

+
+                  [FRPLACD (CDR X0)
+                         (LIST PROP (SETQ NEW (LIST NEW]
+                  (RETURN NEW)))
+              (* ;; "proprty list was initially NIL or a non-lit, or ele it ended in a non-list following an even parity position, e.g.  (A B . C) fall through and add property at beginning of property list.")

+
+              )
+             ((NLISTP (CDR X))
+              (* ;; "property list runs out on an odd parity, or else ends in a non-list following an odd parity, e.g.  (A B C) or (A B C . D) fall through and add at beginning")

+
+              )
+             ((EQ (CAR X)
+                  PROP)                                      (* ; "PROP found")

+
+              [FRPLACA (CDR X)
+                     (SETQ NEW (COND
+                                  (FLG (CONS NEW (CADR X)))
+                                  (T (NCONC1
 (CADR X)
+                                            NEW]
+              (RETURN NEW))
+             (T (SETQ X (CDDR (SETQ X0 X)))
+                (GO LP)))                                    (* ; 
+
                                                           "Add to beginning of property list.")

+
+          [SETPROPLIST ATM (CONS PROP (CONS (SETQ NEW (LIST NEW))
+                                            (GETPROPLIST ATM]
+          (RETURN NEW])
+
+(REMPROP

+  [LAMBDA (ATM PROP)
                                     (* bvm%: "17-Sep-86 17:29")

+    [COND
+       ((NULL (LITATOM ATM))
+        (ERRORX (LIST 14 ATM]
+    (PROG ((X (GETPROPLIST ATM))
+           X0 VAL)
+      LP  [COND
+             ((OR (NLISTP X)
+                  (NLISTP (CDR X)))
+              (RETURN VAL))
+             ((EQ (CAR X)
+                  PROP)
+              (SETQ VAL (OR PROP T))                         (* ; "T in case indicator is NIL")

+
+              [COND
+                 (X0 (FRPLACD (CDR X0)
+                            (CDDR X)))
+                 (T (SETPROPLIST ATM (CDDR X]                (* ; "iterate in case there are more occurrences.  Shouldn't happen unless users manually clobber prop list")

+
+              (SETQ X (CDDR X)))
+             (T (SETQ X (CDDR (SETQ X0 X]
+          (GO LP])
+
+(MEMB

+  [LAMBDA (X Y)
+    (PROG NIL
+      LP  (RETURN (COND
+                     ((NLISTP Y)
+                      NIL)
+                     ((EQ X (CAR Y))
+                      Y)
+                     (T (SETQ Y (CDR Y))
+                        (GO LP])
+
+(CLOSEF?

+  [LAMBDA (FL)                                               (* wt%: 18-MAR-77 12 20)

+                                                             (* ; 
+
                               "useful for resetsaves, in case somebody else might close the file.")

+
+    (AND FL (OPENP FL)
+         (CLOSEF FL])
+)
+
+
+
+(* ; "Need these in order to load even compiled files SYSLOAD")

+
+(DEFINEQ
+
+(LOAD

+  [LAMBDA (FILE LDFLG PRINTFLG PACKAGE)
                  (* ; "Edited  9-Apr-87 18:44 by bvm:")

+
+    (RESETLST (PROG (STREAM TEM)
+                TOP (if
 (FMEMB LDFLG LOADOPTIONS)
+                      elseif
 (AND DWIMFLG (SETQ TEM (FIXSPELL LDFLG NIL LOADOPTIONS T)))
+                        then
 (SETQ LDFLG TEM)
+                      else
 (SETQ LDFLG (ERROR "unrecognized load option" LDFLG))
+                            (GO TOP))
+                    [if
 (AND PACKAGE (NOT (CL:PACKAGEP PACKAGE)))
+                        then
                             (* ; 
+
                                                           "Make sure package arg is ok, too")

+
+                              (SETQ PACKAGE (OR (CL:FIND-PACKAGE PACKAGE)
+                                                (\DTEST PACKAGE 'PACKAGE]
+                    [RESETSAVE NIL (LIST 'CLOSEF? (SETQ STREAM (OPENSTREAM FILE 'INPUT 'OLD 
+                                                                      LOADPARAMETERS]
+                    (RETURN (\LOAD-STREAM
 STREAM LDFLG PRINTFLG (AND PRETTYHEADER T)
+                                   PACKAGE])
+
+(\LOAD-STREAM

+  [LAMBDA (STREAM LDFLG PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)
+    (DECLARE
 (SPECVARS LDFLG PRINTFLG LOAD-VERBOSE-STREAM))
+                                                             (* ; "Edited 29-Jan-88 19:02 by jop")

+
+(* ;;; "Internal function that loads from an already open stream.  LOAD-VERBOSE-STREAM if non-nil is the stream to which to print %"file created%" messages and such.  Similarly, PRINTFLG, if non-nil, is the stream to which to print the value of each expression.")

+
+    (PROG ((*STANDARD-INPUT* STREAM)
+           (FILE (FULLNAME STREAM))
+           (*PACKAGE* *PACKAGE*)
+           (*READTABLE* (PROG1 FILERDTBL                     (* ; "This initial value important for SKIPSEPRCODES below, but *READTABLE* gets reset appropriately before anything else is read")

+                               ))
+           (DFNFLG DFNFLG)
+           (BUILDMAPFLG BUILDMAPFLG)
+           (FILEPKGFLG FILEPKGFLG)
+           (ADDSPELLFLG ADDSPELLFLG)
+           (LISPXHIST LISPXHIST)
+           (PRLST (AND FILEPKGFLG (FILEPKGCHANGES)))
+           (FILECREATEDENV *OLD-INTERLISP-READ-ENVIRONMENT*)
+           FILEMAP FNADRLST ROOTNAME TEM FILECREATEDLST LOADA MAYBEWANTFILEMAP INTERLISP-P 
+           FILECREATEDLOC)
+          (DECLARE
 (SPECVARS DFNFLG BUILDMAPFLG FILEPKGFLG ADDSPELLFLG LISPXHIST FILECREATEDLST 
+                              FILECREATEDENV FILECREATEDLOC FILE))
+          (if
 (AND LOAD-VERBOSE-STREAM FILE)
+              then
 (LISPXTERPRI LOAD-VERBOSE-STREAM)
+                    (if
 (NEQ LOAD-VERBOSE-STREAM T)
+                        then
                             (* ; 
+
                                            "CL:LOAD says to prefix this stuff with comment marker")

+                              (PRIN1 "; Loading " LOAD-VERBOSE-STREAM)) 
+                                                             (* ; 
+
                          "Might use EXEC-FORMAT here except that it isn't defined early in loadup")

+                    (LISPXPRIN1 FILE LOAD-VERBOSE-STREAM)
+                    (LISPXTERPRI LOAD-VERBOSE-STREAM))
+          (if
 (EQ (SETQ DFNFLG LDFLG)
+                      'SYSLOAD)
+              then
 (SETQ DFNFLG T)
+                    (SETQ ADDSPELLFLG NIL)
+                    (SETQ BUILDMAPFLG NIL)
+                    (SETQ FILEPKGFLG NIL)
+                    (SETQ LISPXHIST NIL))
+          (if
 LISPXHIST
+              then
                                       (* ; 
+
                       "Want UNDOSAVE to keep saving regardless of how many undosaves are involved")

+                    (if
 (SETQ LOADA (FMEMB 'SIDE LISPXHIST))
+                        then
 (FRPLACA (CADR LOADA)
+                                        -1)
+                      else
 (LISPXPUT 'SIDE (LIST -1)
+                                      NIL LISPXHIST)))
+          [if
 (EQ (SETQ TEM (SKIPSEPRCODES STREAM))
+                      FASL:SIGNATURE)
+              then
                                       (* ; 
+
                                                           "FASL file handled by FASL loader")

+                    (FASL:PROCESS-FILE STREAM)
+                    [LET [(MANAGED-FILE-P (GET (SETQ ROOTNAME (ROOTFILENAME
 FILE T))
+                                               'FILEDATES]
+                         (if
 (NOT (MEMB
 FILE LOADEDFILELST))
+                             then
                        (* ; 
+
                                                           "Keep track of every file loaded.")

+                                   (SETQ LOADEDFILELST (CONS FILE LOADEDFILELST)))
+                         (if
 MANAGED-FILE-P
+                             then
 (if
 (EQ LDFLG 'SYSLOAD)
+                                          then
 
+
+                                                (* ;; 
+
   "Don't notice DFASL's when you are coming from CL:LOAD, and the user didn't specify a load flag")

+
+                                                (if
 (NOT (MEMB
 ROOTNAME SYSFILES))
+                                                    then
 (SETQ SYSFILES (NCONC1
 SYSFILES 
+                                                                                   ROOTNAME)))
+                                                (SMASHFILECOMS ROOTNAME)
+                                        elseif
 FILEPKGFLG
+                                          then
 (ADDFILE ROOTNAME 'Compiled]
+                    (RETURN FILE)
+            elseif
 (NEQ TEM (CHARCODE "("))
+              then
 (RETURN (\CML-LOAD STREAM PRINTFLG LOAD-VERBOSE-STREAM (CL::DEFAULT-IO-PACKAGE
+                                                                               PACKAGE]
+          (if
 (AND BUILDMAPFLG (RANDACCESSP STREAM))
+              then
 (SETQ MAYBEWANTFILEMAP T))
+          (WITH-READER-ENVIRONMENT FILECREATEDENV
+              (PROG (ADR)
+                LP  (if
 FILEMAP
+                        then
                             (* ; 
+
                                                           "need to build map, so read carefully")

+                              (SETQ LOADA (SKIPSEPRCODES STREAM))
+                              (if
 (OR (SYNTAXP LOADA 'LEFTPAREN)
+                                          (SYNTAXP LOADA 'LEFTBRACKET))
+                                  then
                   (* ; "See if we have a DEFINEQ")

+                                        (SETQ ADR (GETFILEPTR STREAM))
+                                        (READCCODE STREAM)   (* ; "Eat paren")

+                                        (if
 (EQ (RATOM STREAM)
+                                                    'DEFINEQ)
+                                            then
 (SETQ FNADRLST (TCONC NIL ADR))
+                                                  (TCONC FNADRLST NIL)
+                                                  (TCONC FILEMAP (CAR FNADRLST))
+                                                  (GO DEFQLP)) 
+                                                             (* ; "Not a DEFINEQ, so back out")

+                                        (SETFILEPTR STREAM ADR)))
+                    (SELECTQ
 (SETQ LOADA (READ STREAM))
+                          ((STOP NIL) 
+                                 (if
 (EQ LDFLG 'SYSLOAD)
+                                     then
 (if
 (NOT (MEMB
 (SETQ ROOTNAME
+                                                                      (ROOTFILENAME
 FILE
+                                                                             (CDR FILECREATEDLST)))
+                                                                  SYSFILES))
+                                                  then
 (SETQ SYSFILES (NCONC1
 SYSFILES 
+                                                                                 ROOTNAME)))
+                                           (SMASHFILECOMS ROOTNAME)
+                                   elseif
 FILEPKGFLG
+                                     then
 
+
+                                 (* ;; "Do not want any items that are added to FILEPKGCHANGES as a result of being mentioned in this file to remain on FILEPKGCHANGES.  Also, we want items mentioned earlier to be deleted if they are taken care of by this file.  The extra argument to ADDFILE allows it to restore FILEPKGCHANGES to the intersection of its current value and its previous value.")

+
+                                           (ADDFILE FILE T PRLST FILECREATEDLST))
+                                 [if
 FILEMAP
+                                     then
 (PUTFILEMAP FILE (CAR FILEMAP)
+                                                     FILECREATEDLST FILECREATEDENV NIL 
+                                                     FILECREATEDLOC)
+                                           (if
 UPDATEMAPFLG
+                                               then
 (SETFILEPTR STREAM ADR) 
+                                                             (* ; 
+
                                  "address of last expression read.  good hint for finding filemap")

+                                                     (UPDATEFILEMAP STREAM (CAR FILEMAP]
+                                 (if
 (NOT (MEMB
 FILE LOADEDFILELST))
+                                     then
 (/SETTOPVAL 'LOADEDFILELST (CONS FILE LOADEDFILELST)))
+                                 (RETURN))
+                          NIL)
+                    [if
 (LISTP LOADA)
+                        then

+                        (SELECTQ
 (CAR LOADA)
+                              (DEFINE-FILE-INFO              (* ; 
+
                                 "Handle this specially, since we want to remember the environment")

+                                                (SETQ FILECREATEDLOC (GETFILEPTR STREAM))
+                                                [SET-READER-ENVIRONMENT (SETQ LOADA
+                                                                         (SETQ FILECREATEDENV
+                                                                          (\DO-DEFINE-FILE-INFO

+                                                                           NIL
+                                                                           (CDR LOADA]
+                                                (if
 PACKAGE
+                                                    then
 (* ; 
+
                                          "Caller better really mean it--overrides what's on file!")

+                                                          (replace
 REPACKAGE of
 
+                                                                                       FILECREATEDENV
+                                                             with
 (SETQ *PACKAGE*
+                                                                       (OR (CL:FIND-PACKAGE *PACKAGE*
+                                                                                  )
+                                                                           (CL:CERROR 
+                                                                              "Use current *PACKAGE*"
+                                                                                  
+                                                                         "~s does not name a package"
+                                                                                  *PACKAGE*)
+                                                                           *PACKAGE*)))
+                                                          (LISTPUT (fetch
 RESPEC of
 
+                                                                                       FILECREATEDENV
+                                                                          )
+                                                                 :PACKAGE
+                                                                 (CL:PACKAGE-NAME *PACKAGE*))))
+                              (FILECREATED (if
 MAYBEWANTFILEMAP
+                                               then
      (* ; "See if we have a valid file map")

+                                               (SETQ ADR (GETFILEPTR STREAM))
+                                               (if
 [AND (FIXP (SETQ TEM (CADDDR LOADA)))
+                                                            [SETQ TEM (CAR (NLSETQ (SETFILEPTR STREAM
+                                                                                          TEM)
+                                                                                  (READ STREAM]
+                                                            (EQ (CAR TEM)
+                                                                'FILEMAP)
+                                                            (NULL (CAR (SETQ TEM (CADR TEM]
+                                                   then
  (* ; "Has ok map")

+                                                         (PUTFILEMAP FILE TEM NIL FILECREATEDENV)
+                                                 else
    (* ; 
+
                                                           "Need to build a file map as we go")

+                                                       (SETQ FILEMAP (TCONC NIL NIL)))
+                                               (SETFILEPTR STREAM ADR)
+                                               (SETQ MAYBEWANTFILEMAP NIL))
+                                           (SETQ LOADA (\EVAL LOADA)))
+                              (SETQ LOADA (\EVAL LOADA)))
+                      else
                               (* ; 
+
                                                           "Atom found.  Compiled code definition.")

+                            (if
 ADDSPELLFLG
+                                then
 (ADDSPELL LOADA))
+                            (if
 FILEMAP
+                                then
 (SETQ ADR (GETFILEPTR STREAM)))
+                            (LAPRD LOADA)
+                            (if
 FILEMAP
+                                then
 (TCONC FILEMAP (CONS ADR (CONS (GETFILEPTR STREAM)
+                                                                        LOADA]
+                LP1 (if
 PRINTFLG
+                        then
 (PRINT LOADA PRINTFLG))
+                    (GO LP)
+                DEFQLP
+                    (SELCHARQ (SKIPSEPRCODES STREAM)
+                         ((%) %])                            (* ; "Closes DEFINEQ.")

+                              (READCCODE STREAM)
+                              (if
 FNADRLST
+                                  then
 (RPLACA (CDAR FNADRLST)
+                                                  (GETFILEPTR STREAM)))
+                                                             (* ; 
+
                        "FNADRLST is a TCONC format list, hence want to RPLACA CDAR, not just CDR.")

+                              (SETQ LOADA (DEFINE (DREVERSE LOADA)))
+                              (GO LP1))
+                         ((%( %[)                            (* ; 
+
                                                           "another function/definition pair")

+                              (SETQ ADR (GETFILEPTR STREAM))
+                              (SETQ LOADA (CONS (READ STREAM)
+                                                LOADA))
+                              [if
 FNADRLST
+                                  then
 (TCONC FNADRLST (CONS (CAAR LOADA)
+                                                                 (CONS ADR (GETFILEPTR STREAM]
+                              (GO DEFQLP))
+                         NIL)
+                    (ERROR "illegal argument in defineq")))
+          (RETURN FILE])
+
+(FILECREATED

+  [NLAMBDA X
                                             (* ; "Edited 12-Jan-88 10:44 by bvm")

+
+    (DECLARE
 (USEDFREE FILECREATEDLST LOAD-VERBOSE-STREAM))
+    (PROG ((FILEDATE (CAR X))
+           (FILE (CADR X)))
+          (SETQ FILECREATEDLST (NCONC1
 FILECREATEDLST X))
+          (COND
+             (LOAD-VERBOSE-STREAM 
+                    (* ;; "Presumably if user sets prettyheader to NIL, he doesnt want to see any file created messages, even those frm compiled files.")

+
+                    (if
 (NEQ LOAD-VERBOSE-STREAM T)
+                        then
                             (* ; 
+
                                            "CL:LOAD says to prefix this stuff with comment marker")

+
+                              (PRIN1 "; " LOAD-VERBOSE-STREAM))
+                    (LISPXPRIN1 (FILECREATED1
 X)
+                           LOAD-VERBOSE-STREAM)
+                    (LISPXPRIN1 FILEDATE LOAD-VERBOSE-STREAM)
+                    (LISPXTERPRI LOAD-VERBOSE-STREAM)))
+          (COND
+             ((AND FILE (NLISTP FILE))
+              (* ;; "This is just temporary, primarily for keeping dates of system files which are loaded with FILEPKGFLG=NIL.  The real setting up of file property lists is done when ADDFILE is called.")

+
+              (/PUT (ROOTFILENAME
 FILE)
+                    'FILEDATES
+                    (LIST (CONS FILEDATE FILE])
+
+(FILECREATED1

+  [LAMBDA (X)
                                            (* ; "Edited 12-Jan-88 10:44 by bvm")

+
+    (* ;; "performs error checking on filecreated expressions.  returns the thing to be printed.  used by filecreated, and loadfns.")

+
+    (* ;; "FILECREATED expression for source file is of form (FILECREATED date filename mapaddress . historyinfo).  For compiled file, is of form (FILECREATED date (%"compiled on%" sourceFile)). ")

+
+    (LET ((FILE (CADR X)))
+         (COND
+            ((AND NIL (STRINGP FILE))                        (* ; 
+
 "old way of doing COMPILED ON -- we no longer have such files, and the file name can be a string.")

+
+             FILE)
+            ((LISTP FILE)                                    (* ; 
+
    "New.  also used for printing COMPILED ON message.  CDR is a list of files that were compiled.")

+
+             (CAR FILE))
+            (T                                               (* ; 
+
                                                           "FILE is atomic, the name of the file")

+
+               PRETTYHEADER])
+
+(PRETTYCOMPRINT

+  [NLAMBDA (X)
                                           (* bvm%: "22-Sep-86 17:02")

+    (if
 LOAD-VERBOSE-STREAM
+        then
 (if
 (NEQ LOAD-VERBOSE-STREAM T)
+                     then
                                (* ; 
+
                                            "CL:LOAD says to prefix this stuff with comment marker")

+
+                           (PRIN1 "; " LOAD-VERBOSE-STREAM))
+              (LISPXPRINT X LOAD-VERBOSE-STREAM])
+
+(BOOTSTRAP-NAMEFIELD

+  [LAMBDA (FILE SUFFIXFLG)
                               (* bvm%: " 2-Aug-86 14:50")

+    (* ;; "BOOTSTRAP VERSION -- this is replaced by real version from MACHINEINDEPENDENT")

+
+    (PROG ((START 1)
+           POS END)
+          (while
 (SETQ POS (OR (STRPOS '} FILE START)
+                                   (STRPOS '> FILE START)
+                                   (STRPOS '/ FILE START))) do
 (SETQ START (ADD1 POS)))
+          [COND
+             ((SETQ POS (STRPOS '; FILE))
+              (SETQ END (SUB1 POS))
+              (COND
+                 ((EQ (NTHCHARCODE FILE END)
+                      (CHARCODE "."))                        (* ; "eliminates null suffix")

+
+                  (SETQ END (SUB1 END]
+          [COND
+             ((SETQ POS (STRPOS '%. FILE START))
+              (COND
+                 ((NULL SUFFIXFLG)
+                  (SETQ END (SUB1 POS]
+          (RETURN (SUBATOM FILE START END])
+
+(PUTPROPS

+  [NLAMBDA X
                                             (* bvm%: " 8-Sep-86 11:20")

+    (* ;; "Later in the loadup, the PUTPROP is changed to SAVEPUT")

+
+    (MAP (CDR X)
+         [FUNCTION (LAMBDA (Y)
+                     (PUTPROP
 (CAR X)
+                            (CAR Y)
+                            (CADR Y]
+         (FUNCTION CDDR])
+
+(DECLARE%:

+  [NLAMBDA X
                                             (* wt%: "20-OCT-77 13:00")

+    (DECLARE%:1
 X T])
+
+(DECLARE%:1

+  [LAMBDA (X EVALFLG)
                                    (* wt%: "20-OCT-77 13:09")

+    (PROG NIL
+      LP  (COND
+             ((NLISTP X)
+              (RETURN))
+             [(LISTP (CAR X))
+              (AND EVALFLG (COND
+                              ((EQ (CAAR X)
+                                   'DECLARE%:)
+                               (DECLARE%:1
 (CDAR X)
+                                      T))
+                              (T (EVAL (CAR X]
+             (T (SELECTQ
 (CAR X)
+                      ((EVAL@LOAD DOEVAL@LOAD) 
+                             (SETQ EVALFLG T))
+                      (EVAL@LOADWHEN (SETQ EVALFLG (EVAL (CADR X)))
+                                     (SETQ X (CDR X)))
+                      (DONTEVAL@LOAD (SETQ EVALFLG NIL))
+                      NIL)))
+          (SETQ X (CDR X))
+          (GO LP])
+
+(ROOTFILENAME

+  [LAMBDA (NAME COMPFLG)
                                 (* ; "Edited 22-May-92 11:59 by jds")

+
+    (* ;; "Returns the root of the filename NAME, the atom that all file package properties will be associated with.  If NAME names a compiled file, then COMPFLG~=NIL and we assume that the extension is COMPILE.EXT, which is to be stripped off.  We thus have something of an anomaly: We can keep track of 2 symbolic files whose names differ only in extension, but we confuse them when we deal with their compiled versions.")

+
+    (* ;; "The name is always returned in upper case, so that file-system case dependencies don't carry over into Medley, where source file names are NOT case dependent. JDS, fixing AR 11518 5/21/92")

+
+    (U-CASE (NAMEFIELD (COND
+                          ((TYPEP NAME 'STREAM)
+                           (FULLNAME NAME))
+                          (T NAME))
+                   (NOT COMPFLG])
+
+(DEFINE-FILE-INFO

+  [NLAMBDA ARGS
                                          (* bvm%: "13-Oct-86 17:24")

+    (* ;; "Evaluated when it appears at top of file.  Caller (e.g., LOAD) binds reader environment, so we just set it.  Also return the env in case someone wants it.")

+
+    (DECLARE
 (USEDFREE FILECREATEDLOC))
+    (SETQ FILECREATEDLOC (GETFILEPTR))
+    (SET-READER-ENVIRONMENT (\DO-DEFINE-FILE-INFO
 NIL ARGS])
+
+(\DO-DEFINE-FILE-INFO

+  [LAMBDA (STREAM ARGS)
                                  (* bvm%: "14-Oct-86 00:28")

+(* ;;; "Processes the (DEFINE-FILE-INFO . ARGS) at the front of STREAM")

+
+    (LET (PACKAGE READTABLE BASE VALUE)
+         [for
 TAIL on
 ARGS by
 (CDDR TAIL)
+            do
 (SETQ VALUE (CADR TAIL))
+                  (SELECTQ
 (CAR TAIL)
+                        (:PACKAGE (SETQ PACKAGE
+                                   (OR (if
 (LISTP VALUE)
+                                           then
 (LET ((P (EVAL VALUE)))
+                                                         (if
 (TYPEP P 'PACKAGE)
+                                                             then
 P
+                                                           else
 (CL:FIND-PACKAGE P)))
+                                         else
 (CL:FIND-PACKAGE VALUE))
+                                       (ERROR "Can't find package for reader environment" VALUE))))
+                        (:READTABLE (SETQ READTABLE (OR (if
 (LISTP VALUE)
+                                                            then
 (\DTEST (EVAL VALUE)
+                                                                            'READTABLEP)
+                                                          else
 (FIND-READTABLE VALUE))
+                                                        (ERROR 
+                                                       "Can't find read table for reader environment" 
+                                                               VALUE))))
+                        (:BASE (SETQ BASE (OR (\CHECKRADIX (if
 (LISTP VALUE)
+                                                               then
 (EVAL VALUE)
+                                                             else
 VALUE))
+                                              (ERROR "Bad read base for reader environment" VALUE))))
+                        (ERROR "Unrecognized file info key" (CAR TAIL]
+         (create
 READER-ENVIRONMENT
+                REPACKAGE _ (OR PACKAGE *INTERLISP-PACKAGE*)
+                REREADTABLE _ (OR READTABLE FILERDTBL)
+                REBASE _ (OR BASE 10)
+                RESPEC _ ARGS])
+)
+
+(RPAQ? EOLCHARCODE
 (CHCON1 "
+"))
+
+(RPAQ? PRETTYHEADER
 )
+
+(RPAQ? DWIMFLG
 )
+
+(RPAQ? UPDATEMAPFLG
 )
+
+(RPAQ? DFNFLG
 )
+
+(RPAQ? ADDSPELLFLG
 )
+
+(RPAQ? BUILDMAPFLG
 )
+
+(RPAQ? FILEPKGFLG
 )
+
+(RPAQ? SYSFILES
 )
+
+(RPAQ? NOTCOMPILEDFILES
 )
+
+(RPAQ? RESETVARSLST
 )
+
+(RPAQ? LOADPARAMETERS
 '((SEQUENTIAL T)))
+
+(RPAQ? LISPXHIST
 )
+
+(RPAQ? LISPXPRINTFLG
 T)
+
+(RPAQ? PRETTYHEADER
 "File created ")
+
+(RPAQ? LOAD-VERBOSE-STREAM
 T)
+
+(RPAQ? BELLS
 '"")
+
+(RPAQ? LOADOPTIONS
 '(SYSLOAD NIL T PROP ALLPROP))
+
+(RPAQ? PRETTYDEFMACROS
 NIL)
+
+(RPAQ? PRETTYTYPELST
 NIL)
+
+(RPAQ? FILEPKGTYPES
 NIL)
+
+(ADDTOVAR LOADEDFILELST
 )
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS DWIMFLG UPDATEMAPFLG LOADOPTIONS LOADPARAMETERS FILERDTBL SYSFILES)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+[MAPC '((PUTD . /PUTD)
+        (PUTPROP
 . /PUTPROP)
+        (PUTPROP
 . PUT)
+        (PUTPROP
 . SAVEPUT)
+        (ADDPROP
 . /ADDPROP)
+        (PUT . /PUT)
+        (PRIN1 . LISPXPRIN1)
+        (PRIN2 . LISPXPRIN2)
+        (PRINT . LISPXPRINT)
+        (TERPRI . LISPXTERPRI)
+        (SPACES . LISPXSPACES)
+        (GETPROP
 . GETP)
+        (SET . SAVESET)
+        (SET . /SET)
+        (NILL . MISSPELLED?)
+        (SETTOPVAL . /SETTOPVAL)
+        (BOOTSTRAP-NAMEFIELD
 . NAMEFIELD)
+        (BOOTSTRAP-NAMEFIELD
 . COMSNAME)
+        (NILL . RESETRESTORE))
+      (FUNCTION (LAMBDA (X)
+                  (OR (CCODEP (CDR X))
+                      (MOVD
 (CAR X)
+                             (CDR X)
+                             NIL T]
+
+(AND (CCODEP 'BOOTSTRAP-NAMEFIELD)
+     (PUTD 'BOOTSTRAP-NAMEFIELD))
+
+
+(RADIX 10)
+)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE 
+
+(RPAQQ FASL:SIGNATURE
 145)
+
+
+(CONSTANTS FASL:SIGNATURE)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 DEFINE-FILE-INFO DECLARE%: PUTPROPS FILECREATED SELECTQ)
+
+(ADDTOVAR NLAML
 PRETTYCOMPRINT RPAQ? RPAQ RPAQQ)
+
+(ADDTOVAR LAMA
 )
+)
+(PUTPROPS BOOTSTRAP COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1989 1990 
+1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4584 14256 (GETPROP 4594 . 5166) (SETATOMVAL 5168 . 5297) (RPAQQ 5299 . 5352) (RPAQ 
+5354 . 5666) (RPAQ? 5668 . 6038) (MOVD 6040 . 7904) (MOVD? 7906 . 8336) (SELECTQ 8338 . 8525) (
+SELECTQ1 8527 . 8869) (NCONC1 8871 . 9067) (PUTPROP 9069 . 10553) (PROPNAMES 10555 . 10746) (ADDPROP 
+10748 . 12811) (REMPROP 12813 . 13667) (MEMB 13669 . 13928) (CLOSEF? 13930 . 14254)) (14329 39341 (
+LOAD 14339 . 15508) (\LOAD-STREAM 15510 . 30380) (FILECREATED 30382 . 31800) (FILECREATED1 31802 . 
+32910) (PRETTYCOMPRINT 32912 . 33397) (BOOTSTRAP-NAMEFIELD 33399 . 34359) (PUTPROPS 34361 . 34729) (
+DECLARE%: 34731 . 34863) (DECLARE%:1 34865 . 35737) (ROOTFILENAME 35739 . 36687) (DEFINE-FILE-INFO 
+36689 . 37124) (\DO-DEFINE-FILE-INFO 37126 . 39339)))))
+STOP

CLTL2/BREAK-AND-TRACE

@@ -0,0 +1,902 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "SYSTEM")
+
(IL:FILECREATED "13-Oct-93 18:35:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>BREAK-AND-TRACE.;2"
 48661  
+
+      IL:|previous| IL:|date:| " 4-Feb-92 10:31:42" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>BREAK-AND-TRACE.;1")
+
+
+; Copyright (c) 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS)
+
+(IL:RPAQQ IL:BREAK-AND-TRACECOMS

+          (
+
+(IL:* IL:|;;;| "Support for tracing.")

+
+           (IL:VARIABLES XCL:*TRACE-DEPTH* XCL::*TRACED-FNS* IL:TRACEREGION)
+           (IL:FUNCTIONS XCL:CREATE-TRACE-WINDOW)
+           (IL:FUNCTIONS CREATE-TRACED-DEFINITION CONSTRUCT-ENTRY-PRINTING-CODE 
+                  PRINT-TRACE-ENTRY-INFO PRINT-TRACE-EXIT-INFO PRINT-TRACED-ARGUMENT 
+                  PRINT-TRACED-CL-ARGLIST)
+           (IL:VARIABLES XCL:*TRACE-LEVEL* XCL:*TRACE-LENGTH* XCL:*TRACE-VERBOSE* *TRACE-OUTPUT*)
+           (IL:FNS TRACE UNTRACE)
+           (IL:FUNCTIONS XCL:TRACE-FUNCTION)
+           
+
+(IL:* IL:|;;;| "Support for breaking.")

+
+           (IL:FUNCTIONS XCL:BREAK-FUNCTION XCL:UNBREAK-FUNCTION XCL:REBREAK-FUNCTION 
+                  CREATE-BROKEN-DEFINITION UNBREAK-FROM-RESTORE-CALLS FINISH-UNBREAKING)
+           (IL:VARIABLES IL:BROKENFNS XCL::*BREAK-HASH-TABLE* XCL::*UNBROKEN-FNS*)
+           (IL:PROP IL:PROPTYPE IL:BROKEN)
+           
+           (IL:* IL:|;;| "The old Interlisp interface to breaking.")

+
+           (IL:FNS IL:BREAK IL:BREAK0 IL:REBREAK XCL:UNBREAK IL:UNBREAK0)
+           (IL:FNS IL:BREAK1)
+           (IL:SPECIAL-FORMS IL:BREAK1)
+           (XCL:OPTIMIZERS IL:BREAK1)
+           
+           (IL:* IL:|;;| "Arrange for the proper compiler and package")

+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:BREAK-AND-TRACE)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA)
+                         (IL:NLAML IL:BREAK1)
+                         (IL:LAMA)))))
+
+
+
+(IL:* IL:|;;;| "Support for tracing.")

+
+
+(DEFVAR XCL:*TRACE-DEPTH*
 0)
+
+(DEFVAR XCL::*TRACED-FNS*
 NIL
+
+(IL:* IL:|;;;| "A subset of the entries on IL:BROKENFNS, being those that resulted from calls to TRACE as opposed to calls to BREAK-FUNCTION.")

+
+   )
+
+(DEFVAR IL:TRACEREGION
 (IL:|create|
 IL:REGION
+                                  IL:LEFT IL:_ 8
+                                  IL:BOTTOM IL:_ 3
+                                  IL:WIDTH IL:_ 547
+                                  IL:HEIGHT IL:_ 310))
+
+(DEFUN XCL:CREATE-TRACE-WINDOW
 (&KEY (XCL::REGION IL:TRACEREGION)
+                                         (XCL::OPEN? NIL)
+                                         (XCL::TITLE "*Trace-Output*"))
+                                                             (IL:* IL:\; 
+
                                                           "Edited 29-Jan-92 13:14 by jrb:")

+
+(IL:* IL:|;;;| "Create and return a display stream associated with a window suitable for use as the value of *TRACE-OUTPUT*.")

+
+(IL:* IL:|;;;| 
+
"REGION is the initial region of the window.  It defaults to the value of IL:TRACEREGION.")

+
+(IL:* IL:|;;;| "OPEN? is true if the newly-created window should be left opened on the screen.  If false, the window will be closed and will open the first time any output is sent to it.")

+
+(IL:* IL:|;;;| "Because display streams only have an xpointer back to their windows, we give the stream a STREAMPROP pointer to the window; this makes them reference each other circularly, so they'll NEVER be GCed (*sigh*).")

+
+   (LET* ((XCL::WINDOW (IL:CREATEW XCL::REGION XCL::TITLE NIL (NOT XCL::OPEN?)))
+          (STREAM (IL:GETSTREAM XCL::WINDOW)))
+         (IL:DSPSCROLL 'IL:ON XCL::WINDOW)
+         (IL:STREAMPROP STREAM 'IL:WINDOW XCL::WINDOW)
+         STREAM))
+
+(DEFUN CREATE-TRACED-DEFINITION
 (TRACED-FN IN-FN FN-TO-CALL)
+   (MULTIPLE-VALUE-BIND
+    (LAMBDA-CAR ARG-LIST CALLING-FORM)
+    (FUNCTION-WRAPPER-INFO TRACED-FN FN-TO-CALL)
+    `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA)
+                       '(&REST XCL:ARGLIST)
+                       ARG-LIST)
+            ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
+                   `((DECLARE
 (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
+                                                 (LIST ARG-LIST)
+                                                 ARG-LIST)))))
+            (IL:\\CALLME '(:TRACED ,(IF (NULL IN-FN)
+                                        TRACED-FN
+                                        `(,TRACED-FN :IN ,IN-FN))))
+            (LET* (($THE-REAL-TRACE-OUTPUT$ (XCL:FOLLOW-SYNONYM-STREAMS (IL:\\GETSTREAM 
+                                                                               *TRACE-OUTPUT*)))
+                   ($IMAGE-STREAM?$ (IL:IMAGESTREAMP $THE-REAL-TRACE-OUTPUT$)))
+                  (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
+                        (IL:FONTCHANGEFLG $IMAGE-STREAM?$))
+                       (DECLARE
 (SPECIAL IL:FONTCHANGEFLG))
+                       ,@(CONSTRUCT-ENTRY-PRINTING-CODE
 TRACED-FN IN-FN LAMBDA-CAR ARG-LIST))
+                  (LET (($TRACED-FN-VALUES$ (MULTIPLE-VALUE-LIST (LET ((XCL:*TRACE-DEPTH*
+                                                                        (1+ XCL:*TRACE-DEPTH*)))
+                                                                      ,CALLING-FORM))))
+                       (LET ((*STANDARD-OUTPUT* $THE-REAL-TRACE-OUTPUT$)
+                             (IL:FONTCHANGEFLG $IMAGE-STREAM?$))
+                            (DECLARE
 (SPECIAL IL:FONTCHANGEFLG))
+                            (PRINT-TRACE-EXIT-INFO
 ',TRACED-FN ',IN-FN $TRACED-FN-VALUES$))
+                       (VALUES-LIST $TRACED-FN-VALUES$))))))
+
+(DEFUN CONSTRUCT-ENTRY-PRINTING-CODE
 (TRACED-FN IN-FN LAMBDA-CAR ARG-LIST)
+   `((PRINT-TRACE-ENTRY-INFO
 ',TRACED-FN ',IN-FN)
+     (LET
+      ((*PRINT-LEVEL* XCL:*TRACE-LEVEL*)
+       (*PRINT-LENGTH* XCL:*TRACE-LENGTH*))
+      ,@(CASE LAMBDA-CAR
+            ((IL:LAMBDA IL:NLAMBDA) 
+               (IL:IF
 (LISTP ARG-LIST)
+                   IL:THEN
 
+
+                         (IL:* IL:|;;| 
+
                  "Interlisp spread function.  The ARG-LIST is, in fact, a list of argument names.")

+
+                         `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
+                                ,@(IL:FOR
 VAR IL:IN
 ARG-LIST
+                                     IL:COLLECT
 `(PRINT-TRACED-ARGUMENT
 ',VAR ,VAR $$INDENT$$
+                                                            ))))
+                 IL:ELSEIF
 (EQ LAMBDA-CAR 'IL:LAMBDA)
+                   IL:THEN
 
+
+                         (IL:* IL:|;;| 
+
                "Interlisp Lambda no-spread function.  Print out at most *TRACE-LENGTH* arguments.")

+
+                         `((IL:BIND
 ($$INDENT$$ IL:_ (+ 10 (* XCL:*TRACE-DEPTH* 4))) IL:FOR

+                                                                                         
+                                                                                        $ARG-COUNTER$
+                              IL:FROM
 1 IL:TO
 (IF (NULL XCL:*TRACE-LENGTH*)
+                                                          ,ARG-LIST
+                                                          (MIN XCL:*TRACE-LENGTH* ,ARG-LIST))
+                              IL:DO
 (PRINT-TRACED-ARGUMENT
 $ARG-COUNTER$ (IL:ARG ,ARG-LIST 
+                                                                                        $ARG-COUNTER$
+                                                                                        )
+                                               $$INDENT$$)))
+                 IL:ELSE
 
+
+                       (IL:* IL:|;;| "Interlisp NLambda no-spread function.  Print out at most *TRACE-LENGTH* arguments.  Also, be careful to check that the argument list is really a list.")

+
+                       `((LET (($$INDENT$$ (+ 10 (* XCL:*TRACE-DEPTH* 4))))
+                              (IF (LISTP ,ARG-LIST)
+                                  (IL:FOR
 $ARGUMENT$ IL:IN
 ,ARG-LIST IL:AS
 $ARG-COUNTER$
+                                     IL:FROM
 1 IL:WHILE
 (OR (NULL XCL:*TRACE-LENGTH*)
+                                                                    (<= $ARG-COUNTER$ 
+                                                                        XCL:*TRACE-LENGTH*))
+                                     IL:DO
 (PRINT-TRACED-ARGUMENT
 $ARG-COUNTER$ $ARGUMENT$ 
+                                                      $$INDENT$$))
+                                  (PRINT-TRACED-ARGUMENT
 ',ARG-LIST ,ARG-LIST $$INDENT$$))))))
+            ((LAMBDA) 
+
+               (IL:* IL:|;;| "A Common Lisp function.")

+
+               (MULTIPLE-VALUE-BIND (REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS)
+                      (PARSE-CL-ARGLIST ARG-LIST)
+                      `((PRINT-TRACED-CL-ARGLIST
 XCL:ARGLIST ',REQUIRED ',OPTIONAL
+                               ',REST
+                               ',KEY
+                               ,KEY-APPEARED?
+                               ,ALLOW-OTHER-KEYS
+                               (+ 8 (* XCL:*TRACE-DEPTH* 4))
+                               XCL:*TRACE-VERBOSE*))))))))
+
+(DEFUN PRINT-TRACE-ENTRY-INFO
 (TRACED-FN IN-FN)
+   (DECLARE
 (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (SETQ TRACED-FN (OR (GET TRACED-FN 'TRUE-NAME)
+                       TRACED-FN))
+   (SETQ IN-FN (OR (GET IN-FN 'TRUE-NAME)
+                   IN-FN))
+   (IL:SPACES (* XCL:*TRACE-DEPTH* 4))
+   (PRINC (1+ XCL:*TRACE-DEPTH*))
+   (PRINC " - Enter ")
+   (IL:CHANGEFONT IL:BOLDFONT)
+   (PRIN1 TRACED-FN)
+   (IL:CHANGEFONT IL:DEFAULTFONT)
+   (WHEN (NOT (NULL IN-FN))
+       (PRINC " in ")
+       (IL:CHANGEFONT IL:BOLDFONT)
+       (PRIN1 IN-FN)
+       (IL:CHANGEFONT IL:DEFAULTFONT))
+   (PRINC ":")
+   (TERPRI))
+
+(DEFUN PRINT-TRACE-EXIT-INFO
 (TRACED-FN IN-FN FN-VALUES)
+   (DECLARE
 (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (SETQ TRACED-FN (OR (GET TRACED-FN 'TRUE-NAME)
+                       TRACED-FN))
+   (SETQ IN-FN (OR (GET IN-FN 'TRUE-NAME)
+                   IN-FN))
+   (IL:SPACES (* XCL:*TRACE-DEPTH* 4))
+   (PRINC (1+ XCL:*TRACE-DEPTH*))
+   (PRINC " - Exit ")
+   (IL:CHANGEFONT IL:BOLDFONT)
+   (PRIN1 TRACED-FN)
+   (IL:CHANGEFONT IL:DEFAULTFONT)
+   (WHEN (NOT (NULL IN-FN))
+       (PRINC " in ")
+       (IL:CHANGEFONT IL:BOLDFONT)
+       (PRIN1 IN-FN)
+       (IL:CHANGEFONT IL:DEFAULTFONT))
+   (PRINC " =>")
+   (TERPRI)
+   (IL:FOR
 VALUE IL:IN
 FN-VALUES IL:DO
 (IL:SPACES (+ 10 (* XCL:*TRACE-DEPTH* 4)))
+                                               (PRIN1 VALUE)
+                                               (TERPRI)))
+
+(DEFUN PRINT-TRACED-ARGUMENT
 (NAME VALUE INDENT &OPTIONAL PRIN1-THE-NAME?)
+   (IL:SPACES INDENT)
+   (WHEN (TYPEP NAME 'FIXNUM)
+         (PRINC "Arg "))
+   (IF PRIN1-THE-NAME?
+       (PRIN1 NAME)
+       (PRINC NAME))
+   (PRINC " = ")
+   (PRIN1 VALUE)
+   (TERPRI))
+
+(DEFUN PRINT-TRACED-CL-ARGLIST
 (ARGS REQUIRED OPTIONAL REST KEY KEY-APPEARED? ALLOW-OTHER-KEYS 
+                                         SMALL-INDENT VERBOSE?)
+   (DECLARE
 (SPECIAL IL:BOLDFONT IL:DEFAULTFONT))
+   (LET* ((INDENT (+ SMALL-INDENT 2)))
+         (WHEN REQUIRED
+             (IL:FOR
 VAR IL:IN
 REQUIRED IL:DO
 (COND
+                                                             ((NULL ARGS)
+                                                              (IL:SPACES INDENT)
+                                                              (PRINC VAR)
+                                                              (IL:CHANGEFONT IL:BOLDFONT)
+                                                              (PRINC " ** NOT SUPPLIED **")
+                                                              (IL:CHANGEFONT IL:DEFAULTFONT)
+                                                              (TERPRI))
+                                                             (T (PRINT-TRACED-ARGUMENT

+                                                                 VAR
+                                                                 (POP ARGS)
+                                                                 INDENT)))))
+         (WHEN OPTIONAL
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&OPTIONAL)
+                 (TERPRI))
+             (IL:FOR
 VAR IL:IN
 OPTIONAL IL:DO
 (IF (NULL ARGS)
+                                                              (WHEN VERBOSE?
+                                                                  (IL:SPACES INDENT)
+                                                                  (PRINC VAR)
+                                                                  (PRINC " not supplied")
+                                                                  (TERPRI))
+                                                              (PRINT-TRACED-ARGUMENT
 VAR
+                                                                     (POP ARGS)
+                                                                     INDENT))))
+         (WHEN REST
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&REST)
+                 (TERPRI))
+             (PRINT-TRACED-ARGUMENT
 REST ARGS INDENT))
+         (WHEN KEY
+             (WHEN VERBOSE?
+                 (IL:SPACES SMALL-INDENT)
+                 (PRINC '&KEY)
+                 (TERPRI))
+             (IL:FOR
 VAR IL:IN
 KEY IL:DO
 (IL:FOR
 TAIL IL:ON
 ARGS IL:BY
 CDDR
+                                                        IL:DO
 (WHEN (EQ VAR (CAR TAIL))
+                                                                      (PRINT-TRACED-ARGUMENT

+                                                                       VAR
+                                                                       (CADR TAIL)
+                                                                       INDENT T)
+                                                                      (RETURN)))))
+         (WHEN KEY-APPEARED?
+             (LET (TEMP)
+                  (COND
+                     ((ODDP (LENGTH ARGS))
+                      (IL:SPACES SMALL-INDENT)
+                      (IL:CHANGEFONT IL:BOLDFONT)
+                      (PRINC "** Odd-length &KEY argument list: **")
+                      (IL:CHANGEFONT IL:DEFAULTFONT)
+                      (TERPRI)
+                      (IL:SPACES INDENT)
+                      (PRIN1 ARGS)
+                      (TERPRI))
+                     ((SETQ TEMP (IL:FIND
 KEYWORD IL:IN
 ARGS IL:BY
 (CDDR KEYWORD)
+                                    IL:SUCHTHAT
 (IF ALLOW-OTHER-KEYS
+                                                        (NOT (KEYWORDP KEYWORD))
+                                                        (NOT (MEMBER KEYWORD KEY :TEST 'EQ)))))
+                      (IL:SPACES SMALL-INDENT)
+                      (IL:CHANGEFONT IL:BOLDFONT)
+                      (PRINC "** Illegal &KEY argument: **")
+                      (IL:CHANGEFONT IL:DEFAULTFONT)
+                      (TERPRI)
+                      (IL:SPACES INDENT)
+                      (PRIN1 TEMP)
+                      (TERPRI)))))
+         (WHEN (AND (NOT REST)
+                    (NOT KEY-APPEARED?)
+                    (NOT (NULL ARGS)))
+             (IL:SPACES SMALL-INDENT)
+             (IL:CHANGEFONT IL:BOLDFONT)
+             (PRINC "** Extra arguments: **")
+             (IL:CHANGEFONT IL:DEFAULTFONT)
+             (TERPRI)
+             (IL:SPACES INDENT)
+             (PRIN1 ARGS)
+             (TERPRI))))
+
+(DEFVAR XCL:*TRACE-LEVEL*
 NIL
+
+(IL:* IL:|;;;| "What to bind *PRINT-LEVEL* to when printing argument values in TRACE output.")

+
+   )
+
+(DEFVAR XCL:*TRACE-LENGTH*
 NIL
+
+(IL:* IL:|;;;| "What to bind *PRINT-LENGTH* to during the printing of argument values in TRACE output.  Also controls the number of arguments to no-spread functions that will be printed.")

+
+   )
+
+(DEFVAR XCL:*TRACE-VERBOSE*
 T
+
+(IL:* IL:|;;;| "Controls whether or not various parts of TRACE output are printed:")

+
+   (IL:* IL:|;;| "The lambda-list keywords &OPTIONAL, &REST, and &KEY.")

+
+   (IL:* IL:|;;| "Trailing unsupplied &OPTIONAL arguments.")

+
+   )
+
+(DEFVAR *TRACE-OUTPUT*
 (XCL:CREATE-TRACE-WINDOW
))
+(IL:DEFINEQ
+
+(TRACE

+  (IL:NLAMBDA LISP::FNS                                      (IL:* IL:\; 
+
                                                           "Edited  2-Apr-87 16:10 by Pavel")

+    (SETQ LISP::FNS (IL:NLAMBDA.ARGS LISP::FNS))
+    (IF (NULL LISP::FNS)
+        XCL::*TRACED-FNS*
+        (IL:FOR
 LISP::FN IL:IN
 LISP::FNS IL:JOIN
 (IF (CONSP LISP::FN)
+                                                                 (XCL:TRACE-FUNCTION
 (FIRST
+                                                                                          LISP::FN)
+                                                                        :IN
+                                                                        (THIRD LISP::FN))
+                                                                 (XCL:TRACE-FUNCTION
 LISP::FN))))
+    ))
+
+(UNTRACE

+  (IL:NLAMBDA LISP::FNS                                      (IL:* IL:\; 
+
                                                           "Edited  2-Apr-87 16:39 by Pavel")

+    (SETQ LISP::FNS (IL:NLAMBDA.ARGS LISP::FNS))
+    (FLET ((LISP::UNTRACE-ENTRY (LISP::ENTRY)
+                  (IF (CONSP LISP::ENTRY)
+                      (XCL:UNBREAK-FUNCTION
 (FIRST LISP::ENTRY)
+                             :IN
+                             (SECOND LISP::ENTRY))
+                      (XCL:UNBREAK-FUNCTION
 LISP::ENTRY))))
+          (COND
+             ((NULL LISP::FNS)
+              (IL:FOR
 LISP::ENTRY IL:IN
 (REVERSE XCL::*TRACED-FNS*) IL:JOIN
 (
+                                                                                  LISP::UNTRACE-ENTRY
+                                                                                         LISP::ENTRY)
+                     ))
+             ((EQUAL LISP::FNS '(T))
+              (WHEN XCL::*TRACED-FNS*
+                  (LISP::UNTRACE-ENTRY (CAR XCL::*TRACED-FNS*))))
+             (T (IL:FOR
 LISP::FN IL:IN
 LISP::FNS IL:JOIN
 (IF (CONSP LISP::FN)
+                                                                         (XCL:UNBREAK-FUNCTION

+                                                                          (FIRST LISP::FN)
+                                                                          :IN
+                                                                          (THIRD LISP::FN))
+                                                                         (XCL:UNBREAK-FUNCTION

+                                                                          LISP::FN))))))))
+)
+
+(DEFUN XCL:TRACE-FUNCTION
 (XCL::FN-TO-TRACE &KEY ((:IN XCL::IN-FN))
+                                     XCL::REBREAK?)
+   (MULTIPLE-VALUE-BIND (XCL::EXECUTABLE-TO-TRACE XCL::NO-IN-FN)
+          (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-TRACE)
+          (COND
+             ((AND (CONSP XCL::FN-TO-TRACE)
+                   (NOT XCL::EXECUTABLE-TO-TRACE))
+              (IL:FOR
 XCL::FN IL:IN
 XCL::FN-TO-TRACE IL:JOIN
 (XCL:TRACE-FUNCTION

+                                                                          XCL::FN :IN XCL::IN-FN)))
+             ((AND (CONSP XCL::IN-FN)
+                   (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+              (IL:FOR
 XCL::FN IL:IN
 XCL::IN-FN IL:JOIN
 (XCL:TRACE-FUNCTION
 
+                                                                          XCL::FN-TO-TRACE :IN 
+                                                                          XCL::FN)))
+             (T 
+                (IL:* IL:|;;| "General philosophy here: all external functions take the \"real\" names and not the names of the executables; the \"real\" names are the ones that are published on *TRACED-FNS* and the like.")

+
+                (IL:* IL:|;;| "One exception: the BROKEN property is placed on the name of the executable, since that is guaranteed to be a symbol")

+
+                (COND
+                   ((NULL (IL:GETD XCL::EXECUTABLE-TO-TRACE))
+                    (ERROR 'XCL:UNDEFINED-FUNCTION :NAME XCL::FN-TO-TRACE)
+                    NIL)
+                   ((IL:UNSAFE.TO.MODIFY XCL::FN-TO-TRACE "trace")
+                    (FORMAT *ERROR-OUTPUT* "~S not traced.~%" XCL::FN-TO-TRACE)
+                    NIL)
+                   (T (XCL:UNBREAK-FUNCTION
 XCL::FN-TO-TRACE :IN XCL::IN-FN :NO-ERROR T)
+                      (UNLESS XCL::REBREAK?                  (IL:* IL:\; "Save the breaking information for REBREAK, but don't save it if we're being called from REBREAK itself.")

+                          (SETF (GETHASH (IF (NULL XCL::IN-FN)
+                                             XCL::FN-TO-TRACE
+                                             `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN))
+                                       XCL::*BREAK-HASH-TABLE*)
+                                (LIST XCL::FN-TO-TRACE :IN XCL::IN-FN :TRACE? T :REBREAK? T)))
+                      (IF (NULL XCL::IN-FN)
+                          (LET ((XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE))
+                                                    (MAKE-SYMBOL (FORMAT NIL "Original ~A" 
+                                                                        XCL::EXECUTABLE-TO-TRACE)))))
+                               (IL:PUTD XCL::ORIGINAL (IL:GETD XCL::EXECUTABLE-TO-TRACE)
+                                      T)
+                               (IL:PUTD XCL::EXECUTABLE-TO-TRACE (COMPILE NIL (
+
                                                                           CREATE-TRACED-DEFINITION

+                                                                               
+                                                                             XCL::EXECUTABLE-TO-TRACE
+                                                                               NIL XCL::ORIGINAL))
+                                      T)
+                               (SETF (GET XCL::EXECUTABLE-TO-TRACE 'IL:BROKEN)
+                                     XCL::ORIGINAL)
+                               (PUSH XCL::FN-TO-TRACE IL:BROKENFNS)
+                               (PUSH XCL::FN-TO-TRACE XCL::*TRACED-FNS*)
+                               (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-TRACE XCL::*UNBROKEN-FNS*
+                                                                :TEST 'EQUAL))
+                               (LIST XCL::FN-TO-TRACE))
+                          (IF XCL::NO-IN-FN
+                              (ERROR "~S can't be selectively traced :IN ~S" XCL::FN-TO-TRACE 
+                                     XCL::IN-FN)
+                              (LET* ((XCL::EXECUTABLE-TO-TRACE-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN
+                                                                         ))
+                                     (XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::EXECUTABLE-TO-TRACE
+                                                             XCL::EXECUTABLE-TO-TRACE-IN)))
+                                    (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-TRACE-IN 
+                                                    XCL::EXECUTABLE-TO-TRACE))
+                                        (ERROR "~S is not called from ~S." XCL::FN-TO-TRACE 
+                                               XCL::IN-FN))
+                                    (COMPILE XCL::MIDDLE-MAN (CREATE-TRACED-DEFINITION
 
+                                                                    XCL::EXECUTABLE-TO-TRACE 
+                                                                    XCL::EXECUTABLE-TO-TRACE-IN 
+                                                                    XCL::EXECUTABLE-TO-TRACE))
+                                    (CHANGE-CALLS XCL::EXECUTABLE-TO-TRACE XCL::MIDDLE-MAN 
+                                           XCL::EXECUTABLE-TO-TRACE-IN 'UNBREAK-FROM-RESTORE-CALLS)
+                                    (LET ((XCL::ENTRY (LIST XCL::FN-TO-TRACE XCL::IN-FN 
+                                                            XCL::MIDDLE-MAN)))
+                                         (PUSH XCL::ENTRY IL:BROKENFNS)
+                                         (PUSH XCL::ENTRY XCL::*TRACED-FNS*))
+                                    (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-TRACE
+                                                                        :IN
+                                                                        ,XCL::IN-FN)
+                                                                     XCL::*UNBROKEN-FNS* :TEST
+                                                                     'EQUAL))
+                                    (LIST `(,XCL::FN-TO-TRACE :IN ,XCL::IN-FN)))))))))))
+
+
+
+(IL:* IL:|;;;| "Support for breaking.")

+
+
+(DEFUN XCL:BREAK-FUNCTION
 (XCL::FN-TO-BREAK &KEY ((:IN XCL::IN-FN))
+                                     ((:WHEN XCL::WHEN-EXPR)
+                                      T)
+                                     XCL::TRACE? XCL::REBREAK?)
+   (MULTIPLE-VALUE-BIND
+    (XCL::EXECUTABLE-TO-BREAK XCL::NO-IN-FN)
+    (XCL::NAME-OF-EXECUTABLE XCL::FN-TO-BREAK)
+    (COND
+       (XCL::TRACE? (XCL:TRACE-FUNCTION
 XCL::FN-TO-BREAK :IN XCL::IN-FN :REBREAK? XCL::REBREAK?))
+       ((AND (CONSP XCL::FN-TO-BREAK)
+             (NOT XCL::EXECUTABLE-TO-BREAK))
+        (IL:FOR
 XCL::FN IL:IN
 XCL::FN-TO-BREAK
+           IL:JOIN
 (XCL:BREAK-FUNCTION
 XCL::FN :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK?
+                              XCL::REBREAK?)))
+       ((AND (CONSP XCL::IN-FN)
+             (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+        (IL:FOR
 XCL::FN IL:IN
 XCL::IN-FN
+           IL:JOIN
 (XCL:BREAK-FUNCTION
 XCL::FN-TO-BREAK :IN XCL::FN :WHEN XCL::WHEN-EXPR 
+                              :REBREAK? XCL::REBREAK?)))
+       (T
+        (IF (IL:UNSAFE.TO.MODIFY XCL::FN-TO-BREAK "break")
+            (PROGN (FORMAT *ERROR-OUTPUT* "~S not broken." XCL::FN-TO-BREAK)
+                   NIL)
+            (PROGN (UNLESS XCL::REBREAK?                     (IL:* IL:\; "Save the breaking information for REBREAK.  Don't do it, though, if we're being called from REBREAK.")

+                       (SETF (GETHASH (IF (NULL XCL::IN-FN)
+                                          XCL::FN-TO-BREAK
+                                          `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN))
+                                    XCL::*BREAK-HASH-TABLE*)
+                             (LIST XCL::FN-TO-BREAK :IN XCL::IN-FN :WHEN XCL::WHEN-EXPR :REBREAK? T)))
+                   (WHEN (EQ XCL::WHEN-EXPR :ONCE)
+                       (SETQ XCL::WHEN-EXPR
+                             `(FUNCALL ',(LET ((XCL::TRIGGERED-YET? NIL))
+                                              #'(LAMBDA NIL (IF XCL::TRIGGERED-YET?
+                                                                NIL
+                                                                (SETQ XCL::TRIGGERED-YET? T)))))))
+                   (XCL:UNBREAK-FUNCTION
 XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
+                   (IF (NULL XCL::IN-FN)
+                       (LET* ((XCL::ORIGINAL-DEF (OR (IL:GETD XCL::EXECUTABLE-TO-BREAK)
+                                                     (ERROR 'XCL:UNDEFINED-FUNCTION :NAME 
+                                                            XCL::FN-TO-BREAK)))
+                              (XCL::ORIGINAL (LET ((*PRINT-CASE* :UPCASE))
+                                                  (MAKE-SYMBOL (FORMAT NIL "Original ~A" 
+                                                                      XCL::FN-TO-BREAK)))))
+                             (IL:PUTD XCL::ORIGINAL XCL::ORIGINAL-DEF T)
+                             (IL:PUTD XCL::EXECUTABLE-TO-BREAK (COMPILE NIL
+                                                                      (CREATE-BROKEN-DEFINITION

+                                                                       XCL::EXECUTABLE-TO-BREAK 
+                                                                       XCL::EXECUTABLE-TO-BREAK 
+                                                                       XCL::ORIGINAL XCL::WHEN-EXPR 
+                                                                       XCL::EXECUTABLE-TO-BREAK))
+                                    T)
+                             (SETF (GET XCL::EXECUTABLE-TO-BREAK 'IL:BROKEN)
+                                   XCL::ORIGINAL)
+                             (PUSH XCL::FN-TO-BREAK IL:BROKENFNS)
+                             (SETQ XCL::*UNBROKEN-FNS* (DELETE XCL::FN-TO-BREAK XCL::*UNBROKEN-FNS* 
+                                                              :TEST 'EQUAL))
+                             (LIST XCL::FN-TO-BREAK))
+                       (IF XCL::NO-IN-FN
+                           (ERROR "~S can't be selectively broken :IN ~S" XCL::FN-TO-BREAK XCL::IN-FN
+                                  )
+                           (LET* ((XCL::EXECUTABLE-TO-BREAK-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))
+                                  (XCL::MIDDLE-MAN (CONSTRUCT-MIDDLE-MAN XCL::EXECUTABLE-TO-BREAK 
+                                                          XCL::EXECUTABLE-TO-BREAK-IN)))
+                                 (IF (NOT (HAS-CALLS XCL::EXECUTABLE-TO-BREAK-IN 
+                                                 XCL::EXECUTABLE-TO-BREAK))
+                                     (IF (MACRO-FUNCTION XCL::FN-TO-BREAK)
+                                         (ERROR "Macros can't be selectively traced: sorry")
+                                         (ERROR "~S is not called from ~S." XCL::FN-TO-BREAK 
+                                                XCL::IN-FN)))
+                                 (XCL:UNADVISE-FUNCTION XCL::FN-TO-BREAK :IN XCL::IN-FN :NO-ERROR T)
+                                 (COMPILE XCL::MIDDLE-MAN (CREATE-BROKEN-DEFINITION

+                                                           XCL::EXECUTABLE-TO-BREAK XCL::MIDDLE-MAN 
+                                                           XCL::EXECUTABLE-TO-BREAK XCL::WHEN-EXPR
+                                                           `(,XCL::EXECUTABLE-TO-BREAK :IN
+                                                                   ,XCL::EXECUTABLE-TO-BREAK-IN)))
+                                 (CHANGE-CALLS XCL::EXECUTABLE-TO-BREAK XCL::MIDDLE-MAN 
+                                        XCL::EXECUTABLE-TO-BREAK-IN 'UNBREAK-FROM-RESTORE-CALLS)
+                                 (PUSH (LIST XCL::FN-TO-BREAK XCL::IN-FN XCL::MIDDLE-MAN)
+                                       IL:BROKENFNS)
+                                 (SETQ XCL::*UNBROKEN-FNS* (DELETE `(,XCL::FN-TO-BREAK :IN
+                                                                           ,XCL::IN-FN)
+                                                                  XCL::*UNBROKEN-FNS* :TEST
+                                                                  'EQUAL))
+                                 (LIST `(,XCL::FN-TO-BREAK :IN ,XCL::IN-FN)))))))))))
+
+(DEFUN XCL:UNBREAK-FUNCTION
 (XCL::BROKEN-FN &KEY ((:IN XCL::IN-FN))
+                                       XCL::NO-ERROR)
+   (MULTIPLE-VALUE-BIND
+    (XCL::EXECUTABLE-TO-UNBREAK XCL::NO-IN-FN)
+    (XCL::NAME-OF-EXECUTABLE XCL::BROKEN-FN)
+    (COND
+       ((AND (CONSP XCL::BROKEN-FN)
+             (NOT XCL::EXECUTABLE-TO-UNBREAK))
+        (IL:FOR
 XCL::FN IL:IN
 XCL::BROKEN-FN IL:JOIN
 (XCL:UNBREAK-FUNCTION
 XCL::FN 
+                                                                        :IN XCL::IN-FN)))
+       ((AND (CONSP XCL::IN-FN)
+             (NOT (XCL::NAME-OF-EXECUTABLE XCL::IN-FN)))
+        (IL:FOR
 XCL::FN IL:IN
 XCL::IN-FN IL:JOIN
 (XCL:UNBREAK-FUNCTION
 XCL::BROKEN-FN
+                                                                    :IN XCL::FN)))
+       (T (IF (NULL XCL::IN-FN)
+              (LET ((XCL::ORIGINAL (GET XCL::EXECUTABLE-TO-UNBREAK 'IL:BROKEN)))
+                   (COND
+                      ((NULL XCL::ORIGINAL)
+                       (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S is not broken.~%" 
+                                                    XCL::BROKEN-FN))
+                       NIL)
+                      (T (IL:PUTD XCL::EXECUTABLE-TO-UNBREAK (IL:GETD XCL::ORIGINAL)
+                                T)
+                         (REMPROP XCL::EXECUTABLE-TO-UNBREAK 'IL:BROKEN)
+                         (SETQ IL:BROKENFNS (DELETE XCL::BROKEN-FN IL:BROKENFNS :TEST 'EQUAL))
+                         (SETQ XCL::*TRACED-FNS* (DELETE XCL::BROKEN-FN XCL::*TRACED-FNS* :TEST
+                                                        'EQUAL))
+                         (PUSH XCL::BROKEN-FN XCL::*UNBROKEN-FNS*)
+                         (LIST XCL::BROKEN-FN))))
+              (IF XCL::NO-IN-FN
+                  (ERROR "~s can't be selectively unbroken :IN ~s" XCL::BROKEN-FN XCL::IN-FN)
+                  (LET* ((XCL::EXECUTABLE-TO-UNBREAK-IN (XCL::NAME-OF-EXECUTABLE XCL::IN-FN))
+                         (XCL::ENTRY (FIND-IF #'(LAMBDA (XCL::ENTRY)
+                                                       (AND (CONSP XCL::ENTRY)
+                                                            (EQUAL (FIRST XCL::ENTRY)
+                                                                   XCL::BROKEN-FN)
+                                                            (EQUAL (SECOND XCL::ENTRY)
+                                                                   XCL::IN-FN)))
+                                            IL:BROKENFNS))
+                         (XCL::MIDDLE-MAN (THIRD XCL::ENTRY)))
+                        (COND
+                           ((NULL XCL::ENTRY)
+                            (UNLESS XCL::NO-ERROR (FORMAT *ERROR-OUTPUT* "~S :IN ~S is not broken.~%"
+                                                         XCL::BROKEN-FN XCL::IN-FN))
+                            NIL)
+                           (T (CHANGE-CALLS XCL::MIDDLE-MAN XCL::EXECUTABLE-TO-UNBREAK 
+                                     XCL::EXECUTABLE-TO-UNBREAK-IN)
+                              (FINISH-UNBREAKING
 XCL::EXECUTABLE-TO-UNBREAK 
+                                     XCL::EXECUTABLE-TO-UNBREAK-IN XCL::MIDDLE-MAN XCL::ENTRY)
+                              (LIST `(,XCL::BROKEN-FN :IN ,XCL::IN-FN)))))))))))
+
+(DEFUN XCL:REBREAK-FUNCTION
 (XCL::FN-TO-REBREAK &KEY ((:IN XCL::IN-FN)))
+   (COND
+      ((CONSP XCL::FN-TO-REBREAK)
+       (IL:FOR
 XCL::FN IL:IN
 XCL::FN-TO-REBREAK IL:JOIN
 (XCL:REBREAK-FUNCTION
 XCL::FN
+                                                                           :IN XCL::IN-FN)))
+      ((CONSP XCL::IN-FN)
+       (IL:FOR
 XCL::FN IL:IN
 XCL::IN-FN IL:JOIN
 (XCL:REBREAK-FUNCTION
 
+                                                                   XCL::FN-TO-REBREAK :IN XCL::FN)))
+      (T (LET* ((XCL::NAME (IF (NULL XCL::IN-FN)
+                               XCL::FN-TO-REBREAK
+                               `(,XCL::FN-TO-REBREAK :IN ,XCL::IN-FN)))
+                (XCL::INFO (GETHASH XCL::NAME XCL::*BREAK-HASH-TABLE*)))
+               (COND
+                  ((NULL XCL::INFO)
+                   (FORMAT *ERROR-OUTPUT* "~S has never been broken.~%" XCL::NAME)
+                   NIL)
+                  (T (APPLY 'XCL:BREAK-FUNCTION XCL::INFO)))))))
+
+(DEFUN CREATE-BROKEN-DEFINITION
 (WRAPPED-FN-NAME BROKEN-FN-NAME FN-TO-CALL WHEN-EXPR 
+                                           BREAKPOINT-NAME)
+
+(IL:* IL:|;;;| 
+
"WRAPPED-FN-NAME must be the symbol naming the function that will break when it is called.")

+
+(IL:* IL:|;;;| "BROKEN-FN-NAME is the symbol in whose function cell our lambda-form will be put.")

+
+(IL:* IL:|;;;| "FN-TO-CALL is the function-object to be FUNCALL'ed when we want to call the unbroken version of the wrapped function.")

+
+(IL:* IL:|;;;| "BREAKPOINT-NAME is the value the debugger will use for BRKFN.")

+
+(IL:* IL:|;;;| 
+
"We return a lambda-form suitable for being called in order to (possibly) activate the breakpoint.")

+
+   (MULTIPLE-VALUE-BIND
+    (LAMBDA-CAR ARG-LIST CALLING-FORM)
+    (FUNCTION-WRAPPER-INFO WRAPPED-FN-NAME FN-TO-CALL)
+    `(,LAMBDA-CAR ,(IF (EQ LAMBDA-CAR 'LAMBDA)
+                       '(&REST XCL:ARGLIST)
+                       ARG-LIST)
+            ,@(AND ARG-LIST (MEMBER LAMBDA-CAR '(IL:LAMBDA IL:NLAMBDA))
+                   `((DECLARE
 (SPECIAL ,@(IF (SYMBOLP ARG-LIST)
+                                                 (LIST ARG-LIST)
+                                                 ARG-LIST)))))
+            (IL:\\CALLME '(:BROKEN ,BREAKPOINT-NAME))
+            (IF ,WHEN-EXPR
+                (LET (($POS$ (IL:STKNTH -1)))
+                     (UNWIND-PROTECT
+                         (XCL:DEBUGGER :FORM `(FUNCALL ',#'(LAMBDA NIL ,CALLING-FORM))
+                                :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
+                                ',(XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION BREAKPOINT-NAME))
+                         (IL:RELSTK $POS$)))
+                ,CALLING-FORM))))
+
+(DEFUN UNBREAK-FROM-RESTORE-CALLS
 (FROM TO FN)
+
+(IL:* IL:|;;;| "Somebody has restored all of the changed calls in FN, including one we made, changing calls to FROM into calls to TO.  This came about from breaking (FROM :IN FN), where TO was the middle-man.  Undo that breaking.")

+
+   (LET ((ENTRY (FIND-IF #'(LAMBDA (ENTRY)
+                                  (AND (CONSP ENTRY)
+                                       (EQ (FIRST ENTRY)
+                                           FROM)
+                                       (EQ (SECOND ENTRY)
+                                           FN)))
+                       IL:BROKENFNS)))
+        (ASSERT (EQ TO (THIRD ENTRY))
+               NIL "BUG: Inconsistency in SI::UNBREAK-FROM-RESTORE-CALLS")
+        (FINISH-UNBREAKING
 FROM FN TO ENTRY)
+        (FORMAT *TERMINAL-IO* "(~S :IN ~S) unbroken.~%" FROM FN)))
+
+(DEFUN FINISH-UNBREAKING
 (BROKEN-FN IN-FN MIDDLE-MAN ENTRY)
+   (SETQ IL:BROKENFNS (DELETE ENTRY IL:BROKENFNS))
+   (SETQ XCL::*TRACED-FNS* (DELETE ENTRY XCL::*TRACED-FNS*))
+   (PUSH `(,BROKEN-FN :IN ,IN-FN)
+         XCL::*UNBROKEN-FNS*))
+
+(DEFVAR IL:BROKENFNS
 NIL)
+
+(DEFVAR XCL::*BREAK-HASH-TABLE*
 (MAKE-HASH-TABLE :TEST 'EQUAL))
+
+(DEFVAR XCL::*UNBROKEN-FNS*
 NIL)
+
+(IL:PUTPROPS IL:BROKEN
 IL:PROPTYPE
 IGNORE)
+
+
+
+(IL:* IL:|;;| "The old Interlisp interface to breaking.")

+
+(IL:DEFINEQ
+
+(IL:BREAK

+  (IL:NLAMBDA IL:X                                           (IL:* IL:\; 
+
                                                           "Edited 13-Apr-87 13:51 by Pavel")

+    (IL:FOR
 IL:X IL:IN
 (IL:NLAMBDA.ARGS IL:X)
+       IL:JOIN
 (IL:IF
 (OR (IL:LITATOM IL:X)
+                                  (IL:STRING.EQUAL (CADR IL:X)
+                                         "IN"))
+                       IL:THEN
 (IL:BREAK0
 IL:X T)
+                     IL:ELSE
 (IL:APPLY 'IL:BREAK0 IL:X)))))
+
+(IL:BREAK0

+  (IL:LAMBDA (IL:FN IL:WHEN IL:COMS IL:BRKFN)                (IL:* IL:\; 
+
                                                           "Edited 18-Apr-87 18:56 by Pavel")

+    (WHEN IL:COMS (CERROR "Ignore COMS" "Break 'commands' ~S no longer supported." IL:COMS))
+    (WHEN (AND IL:BRKFN (IL:NEQ IL:BRKFN 'IL:BREAK1))
+          (CERROR "Ignore BRKFN" "Unexpected BRKFN passed to BREAK0: ~S" IL:BRKFN))
+    (WHEN (NULL IL:WHEN)
+          (IL:SETQ IL:WHEN T))
+    (COND
+       ((IL:LISTP IL:FN)
+        (COND
+           ((IL:STRING.EQUAL (SECOND IL:FN)
+                   "IN")
+            (XCL:BREAK-FUNCTION
 (FIRST IL:FN)
+                   :IN
+                   (THIRD IL:FN)
+                   :WHEN IL:WHEN))
+           (T (IL:FOR
 IL:X IL:IN
 IL:FN IL:JOIN
 (IL:BREAK0
 IL:X IL:WHEN)))))
+       (T (XCL:BREAK-FUNCTION
 IL:FN :WHEN IL:WHEN)))))
+
+(IL:REBREAK

+  (IL:NLAMBDA IL:FNS                                         (IL:* IL:\; 
+
                                                           "Edited  3-Apr-87 12:07 by Pavel")

+    (IL:SETQ IL:FNS (IL:NLAMBDA.ARGS IL:FNS))
+    (FLET ((IL:REBREAK-FN (IL:FN)
+                  (IL:IF
 (IL:LISTP IL:FN)
+                      IL:THEN
 (XCL:REBREAK-FUNCTION
 (FIRST IL:FN)
+                                         :IN
+                                         (THIRD IL:FN))
+                    IL:ELSE
 (XCL:REBREAK-FUNCTION
 IL:FN))))
+          (COND
+             ((NULL IL:FNS)
+              (IL:FOR
 IL:FN IL:IN
 XCL::*UNBROKEN-FNS* IL:JOIN
 (IL:REBREAK-FN IL:FN)))
+             ((IL:EQUAL IL:FNS '(T))
+              (AND (NOT (NULL XCL::*UNBROKEN-FNS*))
+                   (IL:REBREAK-FN (CAR XCL::*UNBROKEN-FNS*))))
+             (T (IL:FOR
 IL:FN IL:IN
 IL:FNS IL:JOIN
 (IL:REBREAK-FN IL:FN)))))))
+
+(XCL:UNBREAK

+  (IL:NLAMBDA XCL::FNS                                       (IL:* IL:\; 
+
                                                           "Edited  2-Apr-87 16:39 by Pavel")

+    (SETQ XCL::FNS (IL:NLAMBDA.ARGS XCL::FNS))
+    (FLET ((XCL::UNBREAK-ENTRY (XCL::ENTRY)
+                  (IF (CONSP XCL::ENTRY)
+                      (XCL:UNBREAK-FUNCTION
 (FIRST XCL::ENTRY)
+                             :IN
+                             (SECOND XCL::ENTRY))
+                      (XCL:UNBREAK-FUNCTION
 XCL::ENTRY))))
+          (COND
+             ((NULL XCL::FNS)
+              (IL:FOR
 XCL::ENTRY IL:IN
 (REVERSE IL:BROKENFNS) IL:JOIN
 (XCL::UNBREAK-ENTRY
+                                                                                   XCL::ENTRY)))
+             ((EQUAL XCL::FNS '(T))
+              (WHEN IL:BROKENFNS
+                  (XCL::UNBREAK-ENTRY (CAR IL:BROKENFNS))))
+             (T (IL:FOR
 XCL::FN IL:IN
 XCL::FNS IL:JOIN
 (IF (CONSP XCL::FN)
+                                                                       (XCL:UNBREAK-FUNCTION

+                                                                        (FIRST XCL::FN)
+                                                                        :IN
+                                                                        (THIRD XCL::FN))
+                                                                       (XCL:UNBREAK-FUNCTION

+                                                                        XCL::FN))))))))
+
+(IL:UNBREAK0

+  (IL:LAMBDA (IL:FN)                                         (IL:* IL:\; 
+
                                                           "Edited  1-Apr-87 22:12 by Pavel")

+    (IL:IF
 (IL:LISTP IL:FN)
+        IL:THEN
 (XCL:UNBREAK-FUNCTION
 (CAR IL:FN)
+                           :IN
+                           (CADDR IL:FN))
+      IL:ELSE
 (XCL:UNBREAK-FUNCTION
 IL:FN))))
+)
+(IL:DEFINEQ
+
+(IL:BREAK1

+  (IL:NLAMBDA (IL:BRKEXP IL:BRKWHEN IL:BRKFN IL:BRKCOMS IL:BRKTYPE XCL:CONDITION)
+                                                             (IL:* IL:\; 
+
                                                           "Edited 24-Mar-87 16:07 by amd")

+    (IL:|if|
 (EVAL IL:BRKWHEN)
+        IL:|then|
 
+
+              (IL:* IL:|;;| 
+
     "should probably default CONDITION  depending on BRKTYPE to interrupt, breakpoint error, etc.")

+
+              (WHEN IL:BRKCOMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:BRKCOMS T))
+              (LET ((IL:POS (IL:STKNTH 0 IL:BRKFN)))
+                   (UNWIND-PROTECT
+                       (XCL:DEBUGGER :FORM IL:BRKEXP :ENVIRONMENT NIL :STACK-POSITION IL:POS 
+                              :CONDITION (OR XCL:CONDITION (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION
+                                                                  IL:BRKFN)))
+                       (IL:RELSTK IL:POS)))
+      IL:|else|
 (EVAL IL:BRKEXP))))
+)
+
+(XCL:DEFINE-SPECIAL-FORM IL:BREAK1
 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION 
+                                              &ENVIRONMENT IL:ENV)
+   (IL:IF
 (EVAL IL:WHEN IL:ENV)
+       IL:THEN
 (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T))
+             (LET ((IL:POS (IL:STKNTH 0 IL:FN)))
+                  (UNWIND-PROTECT
+                      (XCL:DEBUGGER :FORM IL:EXP :ENVIRONMENT IL:ENV :STACK-POSITION IL:POS 
+                             :CONDITION (OR XCL:CONDITION (XCL:MAKE-CONDITION 'BREAKPOINT :FUNCTION 
+                                                                 IL:FN)))
+                      (IL:RELSTK IL:POS)))
+     IL:ELSE
 (EVAL IL:EXP IL:ENV)))
+
+(XCL:DEFOPTIMIZER IL:BREAK1
 (&OPTIONAL IL:EXP IL:WHEN IL:FN IL:COMS TYPE XCL:CONDITION)
+                                (WHEN IL:COMS (IL:PRINTOUT T "BRKCOMS no longer supported:" IL:COMS T
+                                                     ))
+                                `(FLET
+                                  (($BRKEXP$ NIL ,IL:EXP))
+                                  (IL:IF
 ,IL:WHEN
+                                      IL:THEN

+                                      (LET
+                                       (($POS$ (IL:STKNTH 0 ',IL:FN)))
+                                       (UNWIND-PROTECT
+                                           (XCL:DEBUGGER
+                                            :FORM
+                                            `(FUNCALL ',#'$BRKEXP$)
+                                            :ENVIRONMENT NIL :STACK-POSITION $POS$ :CONDITION
+                                            ,(OR XCL:CONDITION
+                                                 `(IL:LOADTIMECONSTANT (XCL:MAKE-CONDITION
+                                                                        'BREAKPOINT :FUNCTION
+                                                                        ',IL:FN))))
+                                           (IL:RELSTK $POS$)))
+                                    IL:ELSE
 ($BRKEXP$))))
+
+
+
+(IL:* IL:|;;| "Arrange for the proper compiler and package")

+
+
+(IL:PUTPROPS IL:BREAK-AND-TRACE
 IL:FILETYPE
 :COMPILE-FILE)
+
+(IL:PUTPROPS IL:BREAK-AND-TRACE
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE "SYSTEM"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA
 )
+
+(IL:ADDTOVAR IL:NLAML
 IL:BREAK1)
+
+(IL:ADDTOVAR IL:LAMA
 )
+)
+(IL:PRETTYCOMPRINT IL:BREAK-AND-TRACECOMS)
+
+(IL:RPAQQ IL:BREAK-AND-TRACECOMS

+          (
+
+(IL:* IL:|;;;| "Support for tracing.")

+
+           (IL:VARIABLES XCL:*TRACE-DEPTH* XCL::*TRACED-FNS* IL:TRACEREGION)
+           (IL:FUNCTIONS XCL:CREATE-TRACE-WINDOW)
+           (IL:FUNCTIONS CREATE-TRACED-DEFINITION CONSTRUCT-ENTRY-PRINTING-CODE 
+                  PRINT-TRACE-ENTRY-INFO PRINT-TRACE-EXIT-INFO PRINT-TRACED-ARGUMENT 
+                  PRINT-TRACED-CL-ARGLIST)
+           (IL:VARIABLES XCL:*TRACE-LEVEL* XCL:*TRACE-LENGTH* XCL:*TRACE-VERBOSE* *TRACE-OUTPUT*)
+           (IL:FNS TRACE UNTRACE)
+           (IL:FUNCTIONS XCL:TRACE-FUNCTION)
+           
+
+(IL:* IL:|;;;| "Support for breaking.")

+
+           (IL:FUNCTIONS XCL:BREAK-FUNCTION XCL:UNBREAK-FUNCTION XCL:REBREAK-FUNCTION 
+                  CREATE-BROKEN-DEFINITION UNBREAK-FROM-RESTORE-CALLS FINISH-UNBREAKING)
+           (IL:VARIABLES IL:BROKENFNS XCL::*BREAK-HASH-TABLE* XCL::*UNBROKEN-FNS*)
+           (IL:PROP IL:PROPTYPE IL:BROKEN)
+           
+           (IL:* IL:|;;| "The old Interlisp interface to breaking.")

+
+           (IL:FNS IL:BREAK IL:BREAK0 IL:REBREAK XCL:UNBREAK IL:UNBREAK0)
+           (IL:FNS IL:BREAK1)
+           (IL:SPECIAL-FORMS IL:BREAK1)
+           (XCL:OPTIMIZERS IL:BREAK1)
+           
+           (IL:* IL:|;;| "Arrange for the proper compiler and package")

+
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:BREAK-AND-TRACE)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE)
+                         (IL:NLAML IL:BREAK1)
+                         (IL:LAMA)))))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA
 XCL:UNBREAK IL:REBREAK IL:BREAK UNTRACE TRACE)
+
+(IL:ADDTOVAR IL:NLAML
 IL:BREAK1)
+
+(IL:ADDTOVAR IL:LAMA
 )
+)
+(IL:PUTPROPS IL:BREAK-AND-TRACE IL:COPYRIGHT ("Venue & Xerox Corporation" 1987 1988 1990 1991 1992 
+1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (16480 19023 (TRACE 16493 . 17332) (UNTRACE 17334 . 19021)) (38743 43068 (IL:BREAK 
+38756 . 39284) (IL:BREAK0 39286 . 40173) (IL:REBREAK 40175 . 41120) (XCL:UNBREAK 41122 . 42655) (
+IL:UNBREAK0 42657 . 43066)) (43069 44089 (IL:BREAK1 43082 . 44087)))))
+IL:STOP

CLTL2/CMLARRAY-SUPPORT

@@ -0,0 +1,727 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "18-Oct-93 10:31:44" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY-SUPPORT.;2"
 32489  
+
+      |previous| |date:| "12-Oct-93 16:33:46" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLARRAY-SUPPORT.;1")
+
+
+; Copyright (c) 1986, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLARRAY-SUPPORTCOMS)
+
+(RPAQQ CMLARRAY-SUPPORTCOMS

+       (
+        (* |;;| "Record def's")

+
+        (RECORDS ARRAY-HEADER GENERAL-ARRAY ONED-ARRAY TWOD-ARRAY)
+        
+        (* |;;| "Cmlarray support macros and functions")

+
+                                                             (* \; "Fast predicates")

+        (FUNCTIONS %ARRAYP %SIMPLE-ARRAY-P %SIMPLE-STRING-P %STRINGP %VECTORP)
+        (FUNCTIONS %CHECK-CIRCLE-PRINT %CHECK-INDICES %CHECK-NOT-WRITEABLE %EXPAND-BIT-OP 
+               %GENERAL-ARRAY-ADJUST-BASE %GET-ARRAY-OFFSET %GET-BASE-ARRAY)
+        (FUNCTIONS %BIT-TYPE-P %CHAR-TYPE-P %CML-TYPE-TO-TYPENUMBER-EXPANDER %FAT-CHAR-TYPE-P 
+               %FAT-STRING-CHAR-P %GET-TYPE-TABLE-ENTRY %LIT-SIZE-TO-SIZE %LIT-TYPE-TO-TYPE 
+               %LLARRAY-MAKE-ACCESSOR-EXPR %LLARRAY-MAKE-SETTOR-EXPR %LLARRAY-TYPED-GET 
+               %LLARRAY-TYPED-PUT %LLARRAY-TYPEP %MAKE-ARRAY-TYPE-TABLE %MAKE-CML-TYPE-TABLE 
+               %PACK-TYPENUMBER %SMALLFIXP-SMALLPOSP %SMALLPOSP-SMALLFIXP %THIN-CHAR-TYPE-P 
+               %THIN-STRING-CHAR-P %TYPE-SIZE-TO-TYPENUMBER %TYPENUMBER-TO-BITS-PER-ELEMENT 
+               %TYPENUMBER-TO-CML-TYPE %TYPENUMBER-TO-DEFAULT-VALUE %TYPENUMBER-TO-GC-TYPE 
+               %TYPENUMBER-TO-SIZE %TYPENUMBER-TO-TYPE \\GETBASESMALL-FIXP \\GETBASESTRING-CHAR 
+               \\GETBASETHINSTRING-CHAR \\PUTBASESMALL-FIXP \\PUTBASESTRING-CHAR 
+               \\PUTBASETHINSTRING-CHAR)
+        
+
+(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE")

+
+        (STRUCTURES ARRAY-TABLE-ENTRY)
+        
+
+(* |;;;| "These vars contain all the necessary info for typed arrays")

+
+        (VARIABLES %LIT-ARRAY-SIZES %LIT-ARRAY-TABLE %LIT-ARRAY-TYPES)
+        
+
+(* |;;;| "Tables that drives various macros")

+
+        (VARIABLES %ARRAY-TYPE-TABLE %CANONICAL-CML-TYPES)
+        
+
+(* |;;;| "Constants for (SIGNED-BYTE 16)")

+
+        (VARIABLES MAX.SMALLFIXP MIN.SMALLFIXP)
+        
+
+(* |;;;| "Constants for STRING-CHARS")

+
+        (VARIABLES %CHAR-TYPE %BIT-TYPE %THIN-CHAR-TYPENUMBER %FAT-CHAR-TYPENUMBER %MAXTHINCHAR)
+        
+
+(* |;;;| "Array data-type numbers")

+
+        (VARIABLES %GENERAL-ARRAY %ONED-ARRAY %TWOD-ARRAY)
+        
+
+(* |;;;| "Compiler options")

+
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (PROP FILETYPE CMLARRAY-SUPPORT)))
+
+
+
+(* |;;| "Record def's")

+
+(DECLARE\: EVAL@COMPILE
+
+(BLOCKRECORD ARRAY-HEADER
 (
+
+(* |;;;| "Describes common slots of all array headers")

+
+                               (NIL BITS 4)                (* \; "First 8 bits are unused")

+                               (BASE POINTER)                (* \; 
+
      "24 bits of pointer. Points at raw storage or, in the indirect case, at another array header")

+                                                             (* \; "8 bits of flags")

+                               (READ-ONLY-P FLAG)            (* \; 
+
                                                      "Used for headers pointing at symbols pnames")

+                               (INDIRECT-P FLAG)             (* \; 
+
                                        "Points at an array header rather than a raw storage block")

+                               (BIT-P FLAG)                  (* \; "Is a bit array")

+                               (STRING-P FLAG)               (* \; 
+
                                                           "Is a string (implies is a vector)")

+                                                             (* \; 
+
                                   "If any of the following flags are set, the array in non-simple")

+                               (ADJUSTABLE-P FLAG)
+                               (DISPLACED-P FLAG)
+                               (FILL-POINTER-P FLAG)
+                               (EXTENDABLE-P FLAG)
+                               (TYPE-NUMBER BITS 8)          (* \; "8 bits of type + size")

+                               (OFFSET WORD)                 (* \; "For oned and general arrays")

+                               (FILL-POINTER FIXP)           (* \; "For oned and general arrays")

+                               (TOTAL-SIZE FIXP))
+                              (BLOCKRECORD ARRAY-HEADER ((NIL POINTER)
+                                                         (FLAGS BITS 8)
+                                                         (TYPE BITS 4)
+                                                         (SIZE BITS 4)))
+                              (ACCESSFNS (SIMPLE-P (EQ 0 (LOGAND (|fetch|
 (ARRAY-HEADER FLAGS)
+                                                                    |of|
 DATUM)
+                                                                15))))
+                              (SYSTEM))
+
+(DATATYPE GENERAL-ARRAY
 ((NIL BITS 4)                  (* \; "For alignment")

+                             (STORAGE POINTER)               (* \; "24 bits of pointer")

+                             (READ-ONLY-P FLAG)              (* \; "8 bits of flags")

+                             (INDIRECT-P FLAG)
+                             (BIT-P FLAG)
+                             (STRING-P FLAG)
+                             (ADJUSTABLE-P FLAG)
+                             (DISPLACED-P FLAG)
+                             (FILL-POINTER-P FLAG)
+                             (EXTENDABLE-P FLAG)
+                             (TYPE-NUMBER BITS 8)            (* \; "8 bits of typenumber")

+                             (OFFSET WORD)
+                             (FILL-POINTER FIXP)             (* \; 
+
                                                           "As of 2.1, these 2 fields are fixp's.")

+                             (TOTAL-SIZE FIXP)
+                             (DIMS POINTER)))
+
+(DATATYPE ONED-ARRAY
 ((NIL BITS 4)                     (* \; "Don't use high 8 bits")

+                          (BASE POINTER)                     (* \; "The raw storage base")

+                          (READ-ONLY-P FLAG)                 (* \; "8 bits worth of flags")

+                          (NIL BITS 1)                     (* \; 
+
                                                           "Oned array's cann't be indirect")

+                          (BIT-P FLAG)
+                          (STRING-P FLAG)
+                          (NIL BITS 1)                     (* \; 
+
                                                           "Oned-array's cann't be adjustable")

+                          (DISPLACED-P FLAG)
+                          (FILL-POINTER-P FLAG)
+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)               (* \; 
+
                                                           "4 bits of type and 4 bits of size")

+                          (OFFSET WORD)                      (* \; "For displaced arrays")

+                          (FILL-POINTER FIXP)                (* \; "For filled arrays")

+                          (TOTAL-SIZE FIXP)                  (* \; "Total number of elements")

+                          ))
+
+(DATATYPE TWOD-ARRAY
 ((NIL BITS 4)                     (* \; "For alignmnet")

+                          (BASE POINTER)                     (* \; "Raw storage pointer")

+                          (READ-ONLY-P FLAG)                 (* \; "8 bits of flags")

+                          (NIL BITS 1)                     (* \; "Twod arrays cann't be indirect")

+                          (BIT-P FLAG)
+                          (NIL BITS 4)                     (* \; 
+
      "Twod arrays cann't be strings, nor can they be adjustable, displaced, or have fill pointers")

+                          (EXTENDABLE-P FLAG)
+                          (TYPE-NUMBER BITS 8)
+                          (BOUND0 FIXP)                      (* \; "Zero dimension bound")

+                          (BOUND1 FIXP)                      (* \; "One dimension bound")

+                          (TOTAL-SIZE FIXP)))
+)
+
+(/DECLAREDATATYPE 'GENERAL-ARRAY '((BITS 4)
+                                   POINTER FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG (BITS 8)
+                                   WORD FIXP FIXP POINTER)
+       '((GENERAL-ARRAY 0 (BITS . 3))
+         (GENERAL-ARRAY 0 POINTER)
+         (GENERAL-ARRAY 2 (FLAGBITS . 0))
+         (GENERAL-ARRAY 2 (FLAGBITS . 16))
+         (GENERAL-ARRAY 2 (FLAGBITS . 32))
+         (GENERAL-ARRAY 2 (FLAGBITS . 48))
+         (GENERAL-ARRAY 2 (FLAGBITS . 64))
+         (GENERAL-ARRAY 2 (FLAGBITS . 80))
+         (GENERAL-ARRAY 2 (FLAGBITS . 96))
+         (GENERAL-ARRAY 2 (FLAGBITS . 112))
+         (GENERAL-ARRAY 2 (BITS . 135))
+         (GENERAL-ARRAY 3 (BITS . 15))
+         (GENERAL-ARRAY 4 FIXP)
+         (GENERAL-ARRAY 6 FIXP)
+         (GENERAL-ARRAY 8 POINTER))
+       '10)
+
+(/DECLAREDATATYPE 'ONED-ARRAY '((BITS 4)
+                                POINTER FLAG (BITS 1)
+                                FLAG FLAG (BITS 1)
+                                FLAG FLAG FLAG (BITS 8)
+                                WORD FIXP FIXP)
+       '((ONED-ARRAY 0 (BITS . 3))
+         (ONED-ARRAY 0 POINTER)
+         (ONED-ARRAY 2 (FLAGBITS . 0))
+         (ONED-ARRAY 2 (BITS . 16))
+         (ONED-ARRAY 2 (FLAGBITS . 32))
+         (ONED-ARRAY 2 (FLAGBITS . 48))
+         (ONED-ARRAY 2 (BITS . 64))
+         (ONED-ARRAY 2 (FLAGBITS . 80))
+         (ONED-ARRAY 2 (FLAGBITS . 96))
+         (ONED-ARRAY 2 (FLAGBITS . 112))
+         (ONED-ARRAY 2 (BITS . 135))
+         (ONED-ARRAY 3 (BITS . 15))
+         (ONED-ARRAY 4 FIXP)
+         (ONED-ARRAY 6 FIXP))
+       '8)
+
+(/DECLAREDATATYPE 'TWOD-ARRAY '((BITS 4)
+                                POINTER FLAG (BITS 1)
+                                FLAG
+                                (BITS 4)
+                                FLAG
+                                (BITS 8)
+                                FIXP FIXP FIXP)
+       '((TWOD-ARRAY 0 (BITS . 3))
+         (TWOD-ARRAY 0 POINTER)
+         (TWOD-ARRAY 2 (FLAGBITS . 0))
+         (TWOD-ARRAY 2 (BITS . 16))
+         (TWOD-ARRAY 2 (FLAGBITS . 32))
+         (TWOD-ARRAY 2 (BITS . 51))
+         (TWOD-ARRAY 2 (FLAGBITS . 112))
+         (TWOD-ARRAY 2 (BITS . 135))
+         (TWOD-ARRAY 3 FIXP)
+         (TWOD-ARRAY 5 FIXP)
+         (TWOD-ARRAY 7 FIXP))
+       '10)
+
+
+
+(* |;;| "Cmlarray support macros and functions")

+
+
+
+
+(* \; "Fast predicates")

+
+
+(DEFMACRO %ARRAYP
 (ARRAY)
+   (LISP:IF (LISP:SYMBOLP ARRAY)
+       `(OR (%ONED-ARRAY-P ,ARRAY)
+            (%TWOD-ARRAY-P ,ARRAY)
+            (%GENERAL-ARRAY-P ,ARRAY))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,ARRAY))
+                  (OR (%ONED-ARRAY-P ,SYM)
+                      (%TWOD-ARRAY-P ,SYM)
+                      (%GENERAL-ARRAY-P ,SYM))))))
+
+(DEFMACRO %SIMPLE-ARRAY-P
 (ARRAY)
+   (LISP:IF (LISP:SYMBOLP ARRAY)
+       `(AND (%ARRAYP
 ,ARRAY)
+             (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 ,ARRAY))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,ARRAY))
+                  (AND (%ARRAYP
 ,SYM)
+                       (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 ,SYM))))))
+
+(DEFMACRO %SIMPLE-STRING-P
 (STRING)
+   (LISP:IF (LISP:SYMBOLP STRING)
+       `(AND (%ONED-ARRAY-P ,STRING)
+             (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 ,STRING)
+             (|fetch|
 (ARRAY-HEADER STRING-P) |of|
 ,STRING))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,STRING))
+                  (AND (%ONED-ARRAY-P ,SYM)
+                       (|fetch|
 (ARRAY-HEADER SIMPLE-P) |of|
 ,SYM)
+                       (|fetch|
 (ARRAY-HEADER STRING-P) |of|
 ,SYM))))))
+
+(DEFMACRO %STRINGP
 (STRING)
+   (LISP:IF (LISP:SYMBOLP STRING)
+       `(AND (OR (%ONED-ARRAY-P ,STRING)
+                 (%GENERAL-ARRAY-P ,STRING))
+             (|fetch|
 (ARRAY-HEADER STRING-P) |of|
 ,STRING))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,STRING))
+                  (AND (OR (%ONED-ARRAY-P ,SYM)
+                           (%GENERAL-ARRAY-P ,SYM))
+                       (|fetch|
 (ARRAY-HEADER STRING-P) |of|
 ,SYM))))))
+
+(DEFMACRO %VECTORP
 (VECTOR)
+   (LISP:IF (LISP:SYMBOLP VECTOR)
+       `(OR (%ONED-ARRAY-P ,VECTOR)
+            (AND (%GENERAL-ARRAY-P ,VECTOR)
+                 (EQL 1 (LENGTH (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ,VECTOR)))))
+       (LET ((SYM (GENSYM)))
+            `(LET ((,SYM ,VECTOR))
+                  (OR (%ONED-ARRAY-P ,SYM)
+                      (AND (%GENERAL-ARRAY-P ,SYM)
+                           (EQL 1 (LENGTH (|ffetch|
 (GENERAL-ARRAY DIMS) |of|
 ,SYM)))))))))
+
+(DEFMACRO %CHECK-CIRCLE-PRINT
 (OBJECT STREAM &REST PRINT-FORMS)
+
+   (* |;;| "If A has a circle label, print it. If it's not the first time or it has no label, print the contents")

+
+   `(LET (CIRCLELABEL FIRSTTIME)
+         (AND *PRINT-CIRCLE-HASHTABLE* (LISP:MULTIPLE-VALUE-SETQ (CIRCLELABEL FIRSTTIME)
+                                              (PRINT-CIRCLE-LOOKUP ,OBJECT)))
+         (LISP:WHEN CIRCLELABEL
+             (.SPACECHECK. ,STREAM (VECTOR-LENGTH CIRCLELABEL))
+             (LET (*PRINT-CIRCLE-HASHTABLE*)
+                  (DECLARE
 (LISP:SPECIAL *PRINT-CIRCLE-HASHTABLE*))
+                                                             (* \; 
+
                                "No need to print-circle this string (dangerous if we do, in fact)")

+                  (LISP:WRITE-STRING CIRCLELABEL ,STREAM))
+             (LISP:WHEN FIRSTTIME
+                 (.SPACECHECK. ,STREAM 1)
+                 (LISP:WRITE-CHAR #\Space ,STREAM)))
+         (LISP:WHEN (OR (NOT CIRCLELABEL)
+                        FIRSTTIME)
+                ,@PRINT-FORMS)))
+
+(DEFMACRO %CHECK-INDICES
 (ARRAY START-ARG ARGS)
+   `(LISP:DO ((I ,START-ARG (LISP:1+ I))
+              (DIM 0 (LISP:1+ DIM))
+              INDEX)
+             ((> I ,ARGS)
+              T)
+        (SETQ INDEX (ARG ,ARGS I))
+        (LISP:IF (OR (< INDEX 0)
+                     (>= INDEX (LISP:ARRAY-DIMENSION ,ARRAY DIM)))
+               (RETURN NIL))))
+
+(DEFMACRO %CHECK-NOT-WRITEABLE
 (ARRAY TYPE-NUMBER NEWVALUE)
+   `(COND
+       ((|fetch|
 (ARRAY-HEADER READ-ONLY-P) |of|
 ,ARRAY)
+        (%MAKE-ARRAY-WRITEABLE ,ARRAY))
+       ((AND (%THIN-CHAR-TYPE-P
 ,TYPE-NUMBER)
+             (%FAT-STRING-CHAR-P
 ,NEWVALUE))
+        (%MAKE-STRING-ARRAY-FAT ,ARRAY))))
+
+(DEFMACRO %EXPAND-BIT-OP
 (OP BIT-ARRAY1 BIT-ARRAY2 RESULT-BIT-ARRAY)
+   `(PROGN (LISP:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY1))
+               (LISP:ERROR "BIT-ARRAY1 not a bit array: ~S" ,BIT-ARRAY1))
+           (LISP:IF (NOT (BIT-ARRAY-P ,BIT-ARRAY2))
+               (LISP:ERROR "BIT-ARRAY2 not a bit array: ~S" ,BIT-ARRAY2))
+           (LISP:IF (NOT (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,BIT-ARRAY2))
+                  (LISP:ERROR "Bit-arrays not of same dimensions"))
+           (COND
+              ((NULL ,RESULT-BIT-ARRAY)
+               (SETQ ,RESULT-BIT-ARRAY (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS ,BIT-ARRAY1)
+                                              :ELEMENT-TYPE
+                                              'BIT)))
+              ((EQ ,RESULT-BIT-ARRAY T)
+               (SETQ ,RESULT-BIT-ARRAY ,BIT-ARRAY1))
+              ((NOT (AND (BIT-ARRAY-P ,RESULT-BIT-ARRAY)
+                         (EQUAL-DIMENSIONS-P ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+               (LISP:ERROR "Illegal result array")))
+           ,(LISP:ECASE OP
+                ((AND IOR XOR ANDC2 ORC2) `(OR (EQ ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)
+                                               (%DO-LOGICAL-OP 'COPY ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+                ((EQV NAND NOR ANDC1 ORC1) `(%DO-LOGICAL-OP 'NOT ,BIT-ARRAY1 ,RESULT-BIT-ARRAY)))
+           ,(LISP:ECASE OP
+                (AND `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (IOR `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (XOR `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (EQV `(%DO-LOGICAL-OP 'XOR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (NAND `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (NOR `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ANDC1 `(%DO-LOGICAL-OP 'AND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ANDC2 `(%DO-LOGICAL-OP 'CAND ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ORC1 `(%DO-LOGICAL-OP 'OR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY))
+                (ORC2 `(%DO-LOGICAL-OP 'COR ,BIT-ARRAY2 ,RESULT-BIT-ARRAY)))
+           ,RESULT-BIT-ARRAY))
+
+(DEFMACRO %GENERAL-ARRAY-ADJUST-BASE
 (ARRAY ROW-MAJOR-INDEX)
+   `(LISP:IF (|ffetch|
 (GENERAL-ARRAY INDIRECT-P) |of|
 ,ARRAY)
+        (LET ((%OFFSET 0))
+             (SETQ ,ARRAY (%GET-BASE-ARRAY
 ,ARRAY %OFFSET))
+             (SETQ ,ROW-MAJOR-INDEX (+ ,ROW-MAJOR-INDEX %OFFSET))
+             (LISP:IF (NOT (< ,ROW-MAJOR-INDEX (|fetch|
 (ARRAY-HEADER TOTAL-SIZE)
+                                                  |of|
 ,ARRAY)))
+                    (LISP:ERROR "Row-major-index out of bounds (displaced to adjustable?)")))))
+
+(DEFMACRO %GET-ARRAY-OFFSET
 (ARRAY)
+   `(COND
+       ((OR (%ONED-ARRAY-P ,ARRAY)
+            (%GENERAL-ARRAY-P ,ARRAY))
+        (|fetch|
 (ARRAY-HEADER OFFSET) |of|
 ,ARRAY))
+       ((%TWOD-ARRAY-P ,ARRAY)
+        0)))
+
+(DEFMACRO %GET-BASE-ARRAY
 (ARRAY OFFSET)
+   `(LISP:DO ((%BASE-ARRAY ,ARRAY (|fetch|
 (ARRAY-HEADER BASE) |of|
 %BASE-ARRAY)))
+             ((NOT (|fetch|
 (ARRAY-HEADER INDIRECT-P) |of|
 %BASE-ARRAY))
+              %BASE-ARRAY)
+        (SETQ ,OFFSET (+ ,OFFSET (%GET-ARRAY-OFFSET
 %BASE-ARRAY)))))
+
+(DEFMACRO %BIT-TYPE-P
 (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %BIT-TYPE))
+
+(DEFMACRO %CHAR-TYPE-P
 (TYPE-NUMBER)
+   `(EQ (%TYPENUMBER-TO-TYPE
 ,TYPE-NUMBER)
+        %CHAR-TYPE))
+
+(DEFMACRO %CML-TYPE-TO-TYPENUMBER-EXPANDER
 (CML-TYPE)
+   
+         (* *)

+
+   (LET
+    ((SIMPLE-TYPES (REMOVE T (LISP:MAPCAN #'(LISP:LAMBDA (ENTRY)
+                                                   (LISP:IF (NOT (LISTP (CAR ENTRY)))
+                                                       (LIST (CAR ENTRY))))
+                                    %CANONICAL-CML-TYPES)))
+     (COMPOUND-TYPES (LISP:REMOVE-DUPLICATES (LISP:MAPCAN #'(LISP:LAMBDA (ENTRY)
+                                                                   (LISP:IF (LISTP (CAR ENTRY))
+                                                                       (LIST (CAAR ENTRY))))
+                                                    %CANONICAL-CML-TYPES))))
+    `(LISP:IF (EQ ,CML-TYPE T)
+         ,(CADR (LISP:ASSOC T %CANONICAL-CML-TYPES))
+         (LISP:IF (LISTP ,CML-TYPE)
+             (LISP:ECASE (CAR ,CML-TYPE)
+                 (\\\,@ 
+                    (LISP:MAPCAR
+                     #'(LISP:LAMBDA
+                        (TYPE)
+                        `(,TYPE (LISP:ECASE (CADR ,CML-TYPE)
+                                    (\\\,@ (LISP:MAPCAN
+                                            #'(LISP:LAMBDA (ENTRY)
+                                                     (LISP:IF (AND (LISTP (CAR ENTRY))
+                                                                   (EQ (CAAR ENTRY)
+                                                                       TYPE))
+                                                         (LIST (LIST (CADAR ENTRY)
+                                                                     (CADR ENTRY)))))
+                                            %CANONICAL-CML-TYPES)))))
+                     COMPOUND-TYPES)))
+             (LISP:ECASE ,CML-TYPE
+                 (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPE)
+                                              (LISP:ASSOC TYPE %CANONICAL-CML-TYPES))
+                               SIMPLE-TYPES)))))))
+
+(DEFMACRO %FAT-CHAR-TYPE-P
 (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %FAT-CHAR-TYPENUMBER))
+
+(DEFMACRO %FAT-STRING-CHAR-P
 (OBJECT)
+   `(> (LISP:CHAR-CODE ,OBJECT)
+       %MAXTHINCHAR))
+
+(LISP:DEFUN %GET-TYPE-TABLE-ENTRY
 (TYPENUMBER)
+   (CADR (LISP:ASSOC TYPENUMBER %ARRAY-TYPE-TABLE)))
+
+(LISP:DEFUN %LIT-SIZE-TO-SIZE
 (LIT-SIZE)
+   (CADR (LISP:ASSOC LIT-SIZE %LIT-ARRAY-SIZES)))
+
+(LISP:DEFUN %LIT-TYPE-TO-TYPE
 (LIT-TYPE)
+   (CADR (LISP:ASSOC LIT-TYPE %LIT-ARRAY-TYPES)))
+
+(LISP:DEFUN %LLARRAY-MAKE-ACCESSOR-EXPR
 (TYPENUMBER BASE OFFSET)
+   (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY
 TYPENUMBER))
+          (ACCESSOR (ARRAY-TABLE-ENTRY-ACCESSOR ENTRY))
+          (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
+          (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
+         `(,ACCESSOR ,BASE ,(LISP:IF NEEDS-SHIFT-P
+                                `(LLSH ,OFFSET ,NEEDS-SHIFT-P)
+                                OFFSET))))
+
+(LISP:DEFUN %LLARRAY-MAKE-SETTOR-EXPR
 (TYPENUMBER BASE OFFSET NEWVALUE)
+   (LET* ((ENTRY (%GET-TYPE-TABLE-ENTRY
 TYPENUMBER))
+          (SETTOR (ARRAY-TABLE-ENTRY-SETTOR ENTRY))
+          (BITS-PER-ELEMENT (ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT ENTRY))
+          (NEEDS-SHIFT-P (ARRAY-TABLE-ENTRY-NEEDS-SHIFT-P ENTRY)))
+         `(,SETTOR ,BASE ,(LISP:IF NEEDS-SHIFT-P
+                              `(LLSH ,OFFSET ,NEEDS-SHIFT-P)
+                              OFFSET)
+                 ,NEWVALUE)))
+
+(DEFMACRO %LLARRAY-TYPED-GET
 (BASE TYPENUMBER OFFSET)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(%LLARRAY-MAKE-ACCESSOR-EXPR
 (CAR TYPEENTRY)
+                                               BASE OFFSET)))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %LLARRAY-TYPED-PUT
 (BASE TYPENUMBER OFFSET NEWVALUE)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(%LLARRAY-MAKE-SETTOR-EXPR
 (CAR TYPEENTRY)
+                                               BASE OFFSET NEWVALUE)))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %LLARRAY-TYPEP
 (TYPENUMBER VALUE)
+   `(LISP:ECASE ,TYPENUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       (,(ARRAY-TABLE-ENTRY-TYPE-TEST (CADR TYPEENTRY))
+                                        ,VALUE)))
+                      %ARRAY-TYPE-TABLE))))
+
+(LISP:DEFUN %MAKE-ARRAY-TYPE-TABLE
 (LIT-TABLE TYPES SIZES)
+   (LISP:MAPCAN #'(LISP:LAMBDA (TYPE-ENTRY)
+                         (LET ((LIT-TYPE (CAR TYPE-ENTRY)))
+                              (LISP:MAPCAR #'(LISP:LAMBDA (SIZE-ENTRY)
+                                                    (LIST (%TYPE-SIZE-TO-TYPENUMBER
 LIT-TYPE
+                                                                 (CAR SIZE-ENTRY))
+                                                          (CADR SIZE-ENTRY)))
+                                     (CADR TYPE-ENTRY))))
+          LIT-TABLE))
+
+(LISP:DEFUN %MAKE-CML-TYPE-TABLE
 (ARRAY-TABLE)
+   (LISP:MAPCAR #'(LISP:LAMBDA (TYPE-ENTRY)
+                         (LET ((CMLTYPE (ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPE-ENTRY))))
+                              (LIST CMLTYPE (CAR TYPE-ENTRY))))
+          ARRAY-TABLE))
+
+(DEFMACRO %PACK-TYPENUMBER
 (ELTTYPE ELTSIZE)
+   `(\\ADDBASE (LLSH ,ELTTYPE 4)
+           ,ELTSIZE))
+
+(DEFMACRO %SMALLFIXP-SMALLPOSP
 (NUM)
+   `(\\LOLOC ,NUM))
+
+(DEFMACRO %SMALLPOSP-SMALLFIXP
 (NUM)
+   (LET ((SYM (GENSYM)))
+        `(LET ((,SYM ,NUM))
+              (LISP:IF (> ,SYM MAX.SMALLFIXP)
+                  (\\VAG2 |\\SmallNegHi| ,SYM)
+                  ,SYM))))
+
+(DEFMACRO %THIN-CHAR-TYPE-P
 (TYPE-NUMBER)
+   `(EQ ,TYPE-NUMBER %THIN-CHAR-TYPENUMBER))
+
+(DEFMACRO %THIN-STRING-CHAR-P
 (OBJECT)
+   `(<= (LISP:CHAR-CODE ,OBJECT)
+        %MAXTHINCHAR))
+
+(LISP:DEFUN %TYPE-SIZE-TO-TYPENUMBER
 (LIT-TYPE LIT-SIZE)
+   (LET ((TYPE (CADR (LISP:ASSOC LIT-TYPE %LIT-ARRAY-TYPES)))
+         (SIZE (CADR (LISP:ASSOC LIT-SIZE %LIT-ARRAY-SIZES))))
+        (%PACK-TYPENUMBER
 TYPE SIZE)))
+
+(DEFMACRO %TYPENUMBER-TO-BITS-PER-ELEMENT
 (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-BITS-PER-ELEMENT (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-CML-TYPE
 (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ',(ARRAY-TABLE-ENTRY-CML-TYPE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-DEFAULT-VALUE
 (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-DEFAULT-VALUE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-GC-TYPE
 (TYPE-NUMBER)
+   `(LISP:ECASE ,TYPE-NUMBER
+        (\\\,@ (LISP:MAPCAR #'(LISP:LAMBDA (TYPEENTRY)
+                                     `(,(CAR TYPEENTRY)
+                                       ,(ARRAY-TABLE-ENTRY-GC-TYPE (CADR TYPEENTRY))))
+                      %ARRAY-TYPE-TABLE))))
+
+(DEFMACRO %TYPENUMBER-TO-SIZE
 (TYPE-NUMBER)
+   `(LOGAND ,TYPE-NUMBER 15))
+
+(DEFMACRO %TYPENUMBER-TO-TYPE
 (TYPE-NUMBER)
+   `(LRSH ,TYPE-NUMBER 4))
+
+(DEFMACRO \\GETBASESMALL-FIXP
 (BASE OFFSET)
+   `(%SMALLPOSP-SMALLFIXP
 (\\GETBASE ,BASE ,OFFSET)))
+
+(DEFMACRO \\GETBASESTRING-CHAR
 (PTR DISP)
+   `(LISP:CODE-CHAR (\\GETBASE ,PTR ,DISP)))
+
+(DEFMACRO \\GETBASETHINSTRING-CHAR
 (PTR DISP)
+   `(LISP:CODE-CHAR (\\GETBASEBYTE ,PTR ,DISP)))
+
+(DEFMACRO \\PUTBASESMALL-FIXP
 (BASE OFFSET VALUE)
+   `(\\PUTBASE ,BASE ,OFFSET (%SMALLFIXP-SMALLPOSP
 ,VALUE)))
+
+(DEFMACRO \\PUTBASESTRING-CHAR
 (PTR DISP CHAR)
+   `(\\PUTBASE ,PTR ,DISP (LISP:CHAR-CODE ,CHAR)))
+
+(DEFMACRO \\PUTBASETHINSTRING-CHAR
 (PTR DISP CHAR)
+   `(\\PUTBASEBYTE ,PTR ,DISP (LISP:CHAR-CODE ,CHAR)))
+
+
+
+(* |;;;| "Describes each entry of \\ARRAY-TYPE-TABLE")

+
+
+(LISP:DEFSTRUCT (ARRAY-TABLE-ENTRY
 (:TYPE LIST)
+                                       (:CONSTRUCTOR NIL)
+                                       (:COPIER NIL)
+                                       (:PREDICATE NIL))
+   CML-TYPE
+   ACCESSOR
+   SETTOR
+   BITS-PER-ELEMENT
+   GC-TYPE
+   DEFAULT-VALUE
+   NEEDS-SHIFT-P
+   TYPE-TEST)
+
+
+
+(* |;;;| "These vars contain all the necessary info for typed arrays")

+
+
+(LISP:DEFPARAMETER %LIT-ARRAY-SIZES
 '((1BIT 0)
+                                          (8BIT 3)
+                                          (16BIT 4)
+                                          (32BIT 6))
+                                        "Size codes")
+
+(LISP:DEFPARAMETER %LIT-ARRAY-TABLE

+   '((LISP:BASE-CHARACTER ((8BIT (LISP:BASE-CHARACTER \\GETBASETHINSTRING-CHAR 
+                                        \\PUTBASETHINSTRING-CHAR 8 UNBOXEDBLOCK.GCT #\Null NIL
+                                        (LISP:LAMBDA (OBJECT)
+                                               (%THIN-STRING-CHAR-P
 OBJECT))))))
+     (LISP:EXTENDED-CHARACTER ((16BIT (LISP:EXTENDED-CHARACTER \\GETBASESTRING-CHAR 
+                                             \\PUTBASESTRING-CHAR 16 UNBOXEDBLOCK.GCT #\Null NIL
+                                             (LISP:LAMBDA (OBJECT)
+                                                    (LISP:STRING-CHAR-P OBJECT))))))
+     (T ((32BIT (T \\GETBASEPTR \\RPLPTR 32 PTRBLOCK.GCT NIL 1 (LISP:LAMBDA (OBJECT)
+                                                                        T)))))
+     (XPOINTER ((32BIT (XPOINTER \\GETBASEPTR \\PUTBASEPTR 32 UNBOXEDBLOCK.GCT NIL 1 (LISP:LAMBDA
+                                                                                        (OBJECT)
+                                                                                        T)))))
+     (LISP:SINGLE-FLOAT ((32BIT (LISP:SINGLE-FLOAT \\GETBASEFLOATP \\PUTBASEFLOATP 32 
+                                       UNBOXEDBLOCK.GCT 0.0 1 (LISP:LAMBDA (OBJECT)
+                                                                     (FLOATP OBJECT))))))
+     (LISP:UNSIGNED-BYTE ((1BIT ((LISP:UNSIGNED-BYTE 1)
+                                 \\GETBASEBIT \\PUTBASEBIT 1 UNBOXEDBLOCK.GCT 0 NIL
+                                 (LISP:LAMBDA (OBJECT)
+                                        (AND (>= OBJECT 0)
+                                             (<= OBJECT 1)))))
+                          (8BIT ((LISP:UNSIGNED-BYTE 8)
+                                 \\GETBASEBYTE \\PUTBASEBYTE 8 UNBOXEDBLOCK.GCT 0 NIL
+                                 (LISP:LAMBDA (OBJECT)
+                                        (AND (>= OBJECT 0)
+                                             (< OBJECT 256)))))
+                          (16BIT ((LISP:UNSIGNED-BYTE 16)
+                                  \\GETBASE \\PUTBASE 16 UNBOXEDBLOCK.GCT 0 NIL (LISP:LAMBDA
+                                                                                   (OBJECT)
+                                                                                   (SMALLPOSP OBJECT)
+                                                                                   )))))
+     (LISP:SIGNED-BYTE ((16BIT ((LISP:SIGNED-BYTE 16)
+                                \\GETBASESMALL-FIXP \\PUTBASESMALL-FIXP 16 UNBOXEDBLOCK.GCT 0 NIL
+                                (LISP:LAMBDA (OBJECT)
+                                       (AND (>= OBJECT MIN.SMALLFIXP)
+                                            (<= OBJECT MAX.SMALLFIXP)))))
+                        (32BIT ((LISP:SIGNED-BYTE 32)
+                                \\GETBASEFIXP \\PUTBASEFIXP 32 UNBOXEDBLOCK.GCT 0 1
+                                (LISP:LAMBDA (OBJECT)
+                                       (AND (>= OBJECT MIN.FIXP)
+                                            (<= OBJECT MAX.FIXP))))))))
+   "Fields described by record ARRAY-TYPE-TABLE-ENTRY")
+
+(LISP:DEFPARAMETER %LIT-ARRAY-TYPES

+   '((LISP:UNSIGNED-BYTE 0)
+     (LISP:SIGNED-BYTE 1)
+     (T 2)
+     (LISP:SINGLE-FLOAT 3)
+     (LISP:BASE-CHARACTER 4)
+     (LISP:EXTENDED-CHARACTER 4)
+     (XPOINTER 5))
+   "Type codes")
+
+
+
+(* |;;;| "Tables that drives various macros")

+
+
+(LISP:DEFPARAMETER %ARRAY-TYPE-TABLE
 (%MAKE-ARRAY-TYPE-TABLE
 %LIT-ARRAY-TABLE 
+                                                %LIT-ARRAY-TYPES %LIT-ARRAY-SIZES)
+                                         "Drives various macros")
+
+(LISP:DEFPARAMETER %CANONICAL-CML-TYPES
 (%MAKE-CML-TYPE-TABLE
 %ARRAY-TYPE-TABLE))
+
+
+
+(* |;;;| "Constants for (SIGNED-BYTE 16)")

+
+
+(LISP:DEFCONSTANT MAX.SMALLFIXP
 (LISP:1- (EXPT 2 15)))
+
+(LISP:DEFCONSTANT MIN.SMALLFIXP
 (- (EXPT 2 15)))
+
+
+
+(* |;;;| "Constants for STRING-CHARS")

+
+
+(LISP:DEFCONSTANT %CHAR-TYPE
 (%LIT-TYPE-TO-TYPE
 'LISP:BASE-CHARACTER))
+
+(LISP:DEFCONSTANT %BIT-TYPE
 (%TYPE-SIZE-TO-TYPENUMBER
 'LISP:UNSIGNED-BYTE '1BIT))
+
+(LISP:DEFCONSTANT %THIN-CHAR-TYPENUMBER
 (%TYPE-SIZE-TO-TYPENUMBER
 'LISP:BASE-CHARACTER
+                                                   '8BIT))
+
+(LISP:DEFCONSTANT %FAT-CHAR-TYPENUMBER
 (%TYPE-SIZE-TO-TYPENUMBER
 'LISP:BASE-CHARACTER
+                                                  '16BIT))
+
+(LISP:DEFCONSTANT %MAXTHINCHAR
 (LISP:1- (EXPT 2 8)))
+
+
+
+(* |;;;| "Array data-type numbers")

+
+
+(LISP:DEFCONSTANT %GENERAL-ARRAY
 16
+   "General-array-type-number")
+
+(LISP:DEFCONSTANT %ONED-ARRAY
 14
+   "ONED-ARRAY type number")
+
+(LISP:DEFCONSTANT %TWOD-ARRAY
 15
+   "TWOD-ARRAY type number")
+
+
+
+(* |;;;| "Compiler options")

+
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE\: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+
+(PUTPROPS CMLARRAY-SUPPORT
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLARRAY-SUPPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLCHARACTER

@@ -0,0 +1,901 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 10:35:22" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;2"
 39407  
+
+      previous date%: "24-Mar-92 14:42:50" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCHARACTER.;1"
+)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLCHARACTERCOMS)
+
+(RPAQQ CMLCHARACTERCOMS

+       [(COMS                                                (* ; 
+
                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")

+              (FNS CHARCODE CHARCODE.UNDECODE)
+              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
+              (OPTIMIZERS CHARCODE)
+              (ALISTS (DWIMEQUIVLST SELCHARQ)
+                     (PRETTYEQUIVLST SELCHARQ)))
+        (COMS                                                (* ; "Common Lisp CHARACTER type")

+              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
+              (VARIABLES \CHARHI)
+              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
+                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
+              )
+        (COMS                                                (* ; "Basic character fns")

+              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
+              (FUNCTIONS LISP:CODE-CHAR)
+              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
+        [COMS                                                (* ; 
+
                                                        "I/O; Some is here, the rest is in LLREAD.")

+              (FNS CHARACTER.PRINT)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
+                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
+        (COMS 
+              (* ;; "Common lisp character functions")

+
+              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
+                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
+              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
+                     LISP::EXTENDED-CHARACTER-P)
+              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
+        (COMS 
+              (* ;; "Predicates")

+
+              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
+                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                   LISP:UPPER-CASE-P)
+              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+              (FUNCTIONS LISP:DIGIT-CHAR-P)
+              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
+                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
+        (COMS 
+              (* ;; "Internals")

+
+              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
+        (COMS 
+              (* ;; "Compiler options")

+
+              (PROP FILETYPE CMLCHARACTER)
+              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])
+
+
+
+(* ; "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")

+
+(DEFINEQ
+
+(CHARCODE

+  [NLAMBDA (CHAR)
+    (CHARCODE.DECODE CHAR])
+
+(CHARCODE.UNDECODE

+  [LAMBDA (CODE)                                             (* jop%: "26-Aug-86 14:27")

+    (LET [(NAME (LISP:CHAR-NAME
 (LISP:CODE-CHAR
 CODE]
+         (AND NAME (MKSTRING NAME])
+)
+
+(PUTPROPS SELCHARQ
 MACRO
 [F (CONS 'SELECTQ (CONS (CAR F)
+                                                         (MAPLIST (CDR F)
+                                                                (FUNCTION (LAMBDA (I)
+                                                                            (COND
+                                                                               ((CDR I)
+                                                                                (CONS
+                                                                                 (CHARCODE.DECODE
+                                                                                  (CAAR I))
+                                                                                 (CDAR I)))
+                                                                               (T (CAR I])
+
+(PUTPROPS ALPHACHARP
 MACRO
 ((CHAR)
+                                    ([LAMBDA (UCHAR)
+                                       (DECLARE
 (LOCALVARS UCHAR))
+                                       (AND (IGEQ UCHAR (CHARCODE A))
+                                            (ILEQ UCHAR (CHARCODE Z]
+                                     (LOGAND CHAR 95))))
+
+(PUTPROPS DIGITCHARP
 MACRO
 [LAMBDA (CHAR)
+                                     (AND (IGEQ CHAR (CHARCODE 0))
+                                          (ILEQ CHAR (CHARCODE 9])
+
+(PUTPROPS UCASECODE
 MACRO
 (OPENLAMBDA (CHAR)
+                                         (COND
+                                            ((AND (IGEQ CHAR (CHARCODE a))
+                                                  (ILEQ CHAR (CHARCODE z)))
+                                             (LOGAND CHAR 95))
+                                            (T CHAR))))
+
+(DEFOPTIMIZER CHARCODE
 (C)
+                           (KWOTE (CHARCODE.DECODE C T)))
+
+(ADDTOVAR DWIMEQUIVLST
 (SELCHARQ . SELECTQ))
+
+(ADDTOVAR PRETTYEQUIVLST
 (SELCHARQ . SELECTQ))
+
+
+
+(* ; "Common Lisp CHARACTER type")

+
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+(DECLARE%: EVAL@COMPILE
+
+(ACCESSFNS CHARACTER
 [(CODE (\LOLOC (\DTEST DATUM 'CHARACTER]
+                         (CREATE
 (\VAG2 \CHARHI CODE)))
+)
+)
+
+(LISP:DEFCONSTANT \CHARHI
 7)
+
+(LISP:DEFCONSTANT LISP:CHAR-BITS-LIMIT
 1)
+
+(LISP:DEFCONSTANT LISP:CHAR-CODE-LIMIT
 65536)
+
+(LISP:DEFCONSTANT LISP:CHAR-CONTROL-BIT
 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-FONT-LIMIT
 1)
+
+(LISP:DEFCONSTANT LISP:CHAR-HYPER-BIT
 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-META-BIT
 0)
+
+(LISP:DEFCONSTANT LISP:CHAR-SUPER-BIT
 0)
+
+
+
+(* ; "Basic character fns")

+
+(DEFINEQ
+
+(LISP:CHAR-CODE

+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:30")

+    (\LOLOC (\DTEST CHAR 'CHARACTER])
+
+(LISP:CHAR-INT

+  [LAMBDA (CHAR)
+    (LISP:CHAR-CODE
 CHAR])
+
+(LISP:INT-CHAR

+  [LAMBDA (INTEGER)                                          (* lmm " 7-Jul-85 16:50")

+    (LISP:CODE-CHAR
 INTEGER])
+)
+
+(LISP:DEFUN LISP:CODE-CHAR
 (CODE &OPTIONAL (BITS 0)
+                                     (FONT 0))
+   (LISP:IF (AND (EQ BITS 0)
+                 (EQ FONT 0)
+
+                 (* ;; "This checks for smallposp")

+
+                 (EQ (\HILOC CODE)
+                     \SmallPosHi)
+
+                 (* ;; "Character 255 is undefined in all char sets")

+
+                 (NOT (EQ (LDB (BYTE 8 0)
+                               CODE)
+                          255)))
+          (%%CODE-CHAR
 CODE)))
+
+(DEFOPTIMIZER LISP:CHAR-CODE
 (CHAR)
+                                 [LET [(CONSTANT-CHAR (AND (LISP:CONSTANTP CHAR)
+                                                           (LISP:EVAL CHAR]
+                                      (LISP:IF (LISP:CHARACTERP
 CONSTANT-CHAR)
+                                          (\LOLOC CONSTANT-CHAR)
+                                          `(\LOLOC (\DTEST ,CHAR 'CHARACTER)))])
+
+(DEFOPTIMIZER LISP:CHAR-INT
 (CHAR)
+                                `(LISP:CHAR-CODE
 ,CHAR))
+
+(DEFOPTIMIZER LISP:CODE-CHAR
 (CODE &OPTIONAL (BITS 0)
+                                       (FONT 0))
+                                 (LISP:IF (AND (EQ BITS 0)
+                                               (EQ FONT 0))
+                                     [LET
+                                      [(CONSTANT-CODE (AND (LISP:CONSTANTP CODE)
+                                                           (LISP:EVAL CODE]
+                                      (LISP:IF (EQ (\HILOC CONSTANT-CODE)
+                                                   \SmallPosHi)
+                                          (LISP:IF (NOT (EQ (LDB (BYTE 8 0)
+                                                                 CONSTANT-CODE)
+                                                            255))
+                                                 (%%CODE-CHAR
 CONSTANT-CODE))
+                                          `(LET ((%%CODE ,CODE))
+                                                (AND (EQ (\HILOC %%CODE)
+                                                         ,\SmallPosHi)
+                                                     (NOT (EQ (LDB (BYTE 8 0)
+                                                                   %%CODE)
+                                                              255))
+                                                     (%%CODE-CHAR
 %%CODE))))]
+                                     'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:INT-CHAR
 (INTEGER)
+                                `(LISP:CODE-CHAR
 ,INTEGER))
+
+
+
+(* ; "I/O; Some is here, the rest is in LLREAD.")

+
+(DEFINEQ
+
+(CHARACTER.PRINT

+  [LAMBDA (CHAR STREAM)                                      (* ; "Edited 23-Sep-91 21:09 by jrb:")

+    [COND
+       [*PRINT-ESCAPE*                                       (* ; "Name that can be read back")

+              (LET ((PNAME (LISP:CHAR-NAME
 CHAR))
+                    LPN)
+                   [.SPACECHECK. STREAM (+ 2 (COND
+                                                (PNAME (SETQ LPN (LISP:LENGTH PNAME)))
+                                                (T 1]        (* ; 
+
                                                           "Print as #\ followed by charcter name")

+                   (\OUTCHAR STREAM (fetch
 (READTABLEP HASHMACROCHAR) of
 *READTABLE*))
+                   (\OUTCHAR STREAM (CHARCODE
 "\"))
+                   (COND
+                      (PNAME (WRITE-STRING* PNAME STREAM 0 LPN))
+                      (T (\OUTCHAR STREAM (LISP:CHAR-CODE
 CHAR]
+       (T                                                    (* ; "Character as character")

+          (\OUTCHAR STREAM (LISP:CHAR-CODE
 CHAR]
+    T])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+       (NTYPX (LISP:CODE-CHAR
 0 0 0)))
+
+(DEFPRINT 'CHARACTER 'CHARACTER.PRINT)
+)
+
+
+
+(* ;; "Common lisp character functions")

+
+(DEFINEQ
+
+(LISP:CHAR-BIT

+  [LAMBDA (CHAR NAME)                                        (* jop%: "26-Aug-86 15:01")

+    (LISP:ERROR "Bit ~A not supported" NAME])
+
+(LISP:CHAR-BITS

+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:35")

+    (AND (LISP:CHARACTERP
 CHAR)
+         0])
+
+(LISP:CHAR-DOWNCASE

+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 18:01")

+    (%%CODE-CHAR
 (%%CHAR-DOWNCASE-CODE
 (LISP:CHAR-CODE
 CHAR])
+
+(LISP:CHAR-FONT

+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 17:35")

+    (AND (LISP:CHARACTERP
 CHAR)
+         0])
+
+(LISP:CHAR-NAME

+  [LAMBDA (CHAR)                                             (* ; "Edited 19-Mar-87 15:49 by bvm:")

+    (DECLARE
 (GLOBALVARS CHARACTERNAMES CHARACTERSETNAMES))
+    (COND
+       ((EQ CHAR #\Space)                                    (* ; 
+
                                            "Space is special because it is graphic but has a name")

+        "Space")
+       ((LISP:GRAPHIC-CHAR-P
 CHAR)                       (* ; "graphics have no special names")

+        NIL)
+       (T (LET ((CODE (LISP:CHAR-CODE
 CHAR))
+                CSET)
+               (COND
+                  [(for
 X in
 CHARACTERNAMES when
 (EQ (CADR X)
+                                                                 CODE)
+                      do
 (RETURN (CAR X]
+                  (T (SETQ CSET (LRSH CODE 8))
+                     (SETQ CODE (LOGAND CODE 255))
+                     (COND
+                        [(AND (EQ CSET 0)
+                              (<= CODE (CHARCODE
 "^Z"))) (* ; 
+
                                                           "represent ascii control chars nicely")

+                         (CONCAT "^" (LISP:CODE-CHAR
 (LOGOR CODE (- (CHARCODE
 "A")
+                                                                        (CHARCODE
 "^A"]
+                        (T                                   (* ; "Else charset-charcode")

+                           (CONCAT (for
 X in
 CHARACTERSETNAMES
+                                      when
 (EQ (CADR X)
+                                                   CSET) do
 (RETURN (CAR X))
+                                      finally
 (RETURN (OCTALSTRING CSET)))
+                                  "-"
+                                  (OCTALSTRING CODE])
+
+(LISP:CHAR-UPCASE

+  [LAMBDA (CHAR)                                             (* jop%: "25-Aug-86 18:01")

+    (%%CODE-CHAR
 (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 CHAR])
+
+(LISP:CHARACTER

+  [LAMBDA (OBJECT)                                           (* jop%: "14-Nov-86 16:22")

+    (COND
+       ((TYPEP OBJECT 'LISP:CHARACTER)
+        OBJECT)
+       ((AND (NOT *CLTL2-PEDANTIC*)
+             (TYPEP OBJECT 'LISP:FIXNUM))
+        (LISP:INT-CHAR
 OBJECT))
+       ([AND (OR (TYPEP OBJECT 'STRING)
+                 (TYPEP OBJECT 'LISP:SYMBOL))
+             (EQL 1 (LISP:LENGTH (SETQ OBJECT (STRING OBJECT]
+        (LISP:CHAR OBJECT 0))
+       (T (LISP:ERROR "Object cannot be coerced to a character: ~S" OBJECT])
+
+(LISP:NAME-CHAR

+  [LAMBDA (NAME)                                             (* ; "Edited 18-Feb-87 22:05 by bvm:")

+    (LET ((CODE (CHARCODE.DECODE (STRING NAME)
+                       T)))
+         (AND CODE (LISP:CODE-CHAR
 CODE])
+
+(LISP:SET-CHAR-BIT

+  [LAMBDA (CHAR NAME NEWVALUE)                               (* jop%: "26-Aug-86 15:02")

+    (LISP:ERROR "Bit ~A not supported" NAME])
+)
+
+(LISP:DEFUN LISP:DIGIT-CHAR
 (WEIGHT &OPTIONAL (RADIX 10)
+                                       (FONT 0))
+   [AND (EQ FONT 0)
+        (< -1 WEIGHT RADIX 37)
+        (LISP:IF (< WEIGHT 10)
+            (%%CODE-CHAR
 (+ (CONSTANT (LISP:CHAR-CODE
 #\0))
+                                WEIGHT))
+            (%%CODE-CHAR
 (+ (CONSTANT (LISP:CHAR-CODE
 #\A))
+                                (- WEIGHT 10))))])
+
+(LISP:DEFUN LISP:MAKE-CHAR
 (CHAR &OPTIONAL (BITS 0)
+                                     (FONT 0))
+   (LISP:IF (AND (EQL BITS 0)
+                 (EQL FONT 0))
+          CHAR))
+
+(LISP:DEFUN LISP::BASE-CHARACTER-P
 (LISP::OBJECT)        (* ; "Edited 13-Feb-92 19:51 by jrb:")

+   (AND (LISP:CHARACTERP
 LISP::OBJECT)
+
+        (* ;; "Same as (NOT (%%%%FAT-STRING-CHAR-P object))")

+
+        (ILEQ (\LOLOC LISP::OBJECT)
+              %%MAXTHINCHAR)))
+
+(LISP:DEFUN LISP::EXTENDED-CHARACTER-P
 (LISP::OBJECT)    (* ; "Edited 13-Feb-92 20:18 by jrb:")

+   (AND (LISP:CHARACTERP
 LISP::OBJECT)
+
+        (* ;; "Same as (%%%%FAT-STRING-CHAR-P object)")

+
+        (IGREATERP (\LOLOC LISP::OBJECT)
+               %%MAXTHINCHAR)))
+
+(DEFOPTIMIZER LISP:CHAR-UPCASE
 (CHAR)
+                                   `[%%CODE-CHAR
 (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

+                                                                              ,CHAR])
+
+(DEFOPTIMIZER LISP:CHAR-DOWNCASE
 (CHAR)
+                                     `[%%CODE-CHAR
 (%%CHAR-DOWNCASE-CODE
 (LISP:CHAR-CODE

+                                                                                  ,CHAR])
+
+(DEFOPTIMIZER LISP:MAKE-CHAR
 (CHAR &OPTIONAL BITS FONT)
+                                 (LISP:IF (AND (OR (NULL BITS)
+                                                   (EQL BITS 0))
+                                               (OR (NULL FONT)
+                                                   (EQL FONT 0)))
+                                     CHAR
+                                     'COMPILER:PASS))
+
+
+
+(* ;; "Predicates")

+
+(DEFINEQ
+
+(LISP:ALPHA-CHAR-P

+  [LAMBDA (CHAR)                                             (* raf "23-Oct-85 15:03")

+    (LET ((CODE (LISP:CHAR-CODE
 CHAR)))                  (* ; 
+
                                           "Might want to make this true for Greek char sets, etc.")

+         (OR (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
+                 CODE
+                 (CONSTANT (LISP:CHAR-CODE
 #\Z)))
+             (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
+                 CODE
+                 (CONSTANT (LISP:CHAR-CODE
 #\z])
+
+(LISP:ALPHANUMERICP

+  [LAMBDA (CHAR)                                             (* lmm "28-Oct-85 20:40")

+    (OR (LISP:ALPHA-CHAR-P
 CHAR)
+        (NOT (NULL (LISP:DIGIT-CHAR-P
 CHAR])
+
+(LISP:BOTH-CASE-P

+  [LAMBDA (CHAR)
+    (OR (LISP:UPPER-CASE-P
 CHAR)
+        (LISP:LOWER-CASE-P
 CHAR])
+
+(LISP:CHARACTERP

+  [LAMBDA (OBJECT)                                           (* lmm " 1-Aug-85 22:45")

+    (TYPENAMEP OBJECT 'CHARACTER])
+
+(LISP:GRAPHIC-CHAR-P

+  [LAMBDA (CHAR)                                             (* bvm%: "14-May-86 16:19")

+
+(* ;;; 
+
"True if CHAR represents a graphic (printing) character.  Definition follows NS character standard")

+
+    (LET* ((CODE (LISP:CHAR-CODE
 CHAR))
+           (CSET (LRSH CODE 8)))
+          (AND [PROGN                                        (* ; 
+
                                             "Graphic charsets are zero, 41 thru 176, 241 thru 276")

+                      (OR (EQ CSET 0)
+                          (AND (> (SETQ CSET (LOGAND CSET 127))
+                                  32)
+                               (NOT (EQ CSET 127]
+               (PROGN                                        (* ; 
+
                        "Printing chars within a character set are SPACE thru 176 and 241 thru 276")

+                      (OR (EQ (SETQ CODE (LOGAND CODE 255))
+                              (CONSTANT (LISP:CHAR-CODE
 #\Space)))
+                          (AND (> (SETQ CODE (LOGAND CODE 127))
+                                  32)
+                               (NOT (EQ CODE 127])
+
+(LISP:LOWER-CASE-P

+  [LAMBDA (CHAR)
+    (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
+        (LISP:CHAR-CODE
 CHAR)
+        (CONSTANT (LISP:CHAR-CODE
 #\z])
+
+(LISP:STANDARD-CHAR-P

+  [LAMBDA (CHAR)                                             (* ; "Edited  7-Jan-87 11:42 by jop")

+    (AND (LISP:MEMBER CHAR
+                '(#\! #\" #\# #\$ #\% #\& #\' #\( #\) #\* #\+ #\, #\- #\. #\/ #\0 #\1 #\2 #\3 #\4 #\5
+                      #\6 #\7 #\8 #\9 #\: #\; #\< #\= #\> #\? #\@ #\A #\B #\C #\D #\E #\F #\G #\H #\I
+                      #\J #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z #\[ #\\ #\]
+                      #\^ #\_ #\` #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n #\o #\p #\q
+                      #\r #\s #\t #\u #\v #\w #\x #\y #\z #\{ #\| #\} #\~ #\Space #\Newline))
+         T])
+
+(LISP:STRING-CHAR-P

+  [LAMBDA (CHAR)
+    (\DTEST CHAR 'CHARACTER])
+
+(LISP:UPPER-CASE-P

+  [LAMBDA (CHAR)
+    (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
+        (LISP:CHAR-CODE
 CHAR)
+        (CONSTANT (LISP:CHAR-CODE
 #\Z])
+)
+(DEFINEQ
+
+(LISP:CHAR-EQUAL

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 16:03")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-EQUAL takes at least one arg"))
+    (LISP:DO ((TEST (LISP:CHAR-UPCASE
 (ARG N 1)))
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (LISP:IF [NOT (EQ TEST (LISP:CHAR-UPCASE
 (ARG N I]
+               (RETURN NIL)))])
+
+(LISP:CHAR-GREATERP

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:15")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N I]
+        (LISP:IF (NOT (> LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-LESSP

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:17")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N I]
+        (LISP:IF (NOT (< LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-NOT-EQUAL

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 16:02")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-NOT-EQUAL takes at least one arg"))
+    (LISP:DO ((I 1 (LISP:1+ I))
+              TEST)
+             ((> I N)
+              T)
+        (SETQ TEST (LISP:CHAR-UPCASE
 (ARG N I)))
+        (LISP:IF (LISP:DO ((J (LISP:1+ I)
+                              (LISP:1+ J)))
+                          ((> J N)
+                           NIL)
+                     (LISP:IF (EQ TEST (LISP:CHAR-UPCASE
 (ARG N J)))
+                            (RETURN T)))
+               (RETURN NIL)))])
+
+(LISP:CHAR-NOT-GREATERP

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:18")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N I]
+        (LISP:IF (NOT (<= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR-NOT-LESSP

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:19")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR-LESSP takes at least one arg"))
+    (LISP:DO ([LAST (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N 1]
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        [SETQ NEXT (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 (ARG N I]
+        (LISP:IF (NOT (>= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR/=

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:07")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR/= takes at least one arg"))
+    (LISP:DO ((I 1 (LISP:1+ I))
+              TEST)
+             ((> I N)
+              T)
+        (SETQ TEST (LISP:CHAR-CODE
 (ARG N I)))
+        (LISP:IF (LISP:DO ((J (LISP:1+ I)
+                              (LISP:1+ J)))
+                          ((> J N)
+                           NIL)
+                     (LISP:IF (EQ TEST (LISP:CHAR-CODE
 (ARG N J)))
+                            (RETURN T)))
+               (RETURN NIL)))])
+
+(LISP:CHAR<

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:29")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE
 (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE
 (ARG N I)))
+        (LISP:IF (NOT (< LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR<=

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:38")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE
 (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE
 (ARG N I)))
+        (LISP:IF (NOT (<= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR=

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 17:05")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR= takes at least one arg"))
+    (LISP:DO ((TEST (LISP:CHAR-CODE
 (ARG N 1)))
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (LISP:IF [NOT (EQ TEST (LISP:CHAR-CODE
 (ARG N I]
+               (RETURN NIL)))])
+
+(LISP:CHAR>

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:34")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE
 (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE
 (ARG N I)))
+        (LISP:IF (NOT (> LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+
+(LISP:CHAR>=

+  [LAMBDA N                                                  (* jop%: "25-Aug-86 14:40")

+    (LISP:IF (< N 1)
+           (LISP:ERROR "CHAR< takes at least one arg"))
+    (LISP:DO ((LAST (LISP:CHAR-CODE
 (ARG N 1)))
+              NEXT
+              (I 2 (LISP:1+ I)))
+             ((> I N)
+              T)
+        (SETQ NEXT (LISP:CHAR-CODE
 (ARG N I)))
+        (LISP:IF (NOT (>= LAST NEXT))
+            (RETURN NIL)
+            (SETQ LAST NEXT)))])
+)
+
+(LISP:DEFUN LISP:DIGIT-CHAR-P
 (CHAR &OPTIONAL (RADIX 10))
+   "Returns the weigh of CHAR in radix RADIX, or NIL if CHAR is not a digit char in that radix."
+   (LET* [(CODE (LISP:CHAR-CODE
 CHAR))
+          (VAL (COND
+                  [(<= (CONSTANT (LISP:CHAR-CODE
 #\0))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE
 #\9)))
+                   (- CODE (CONSTANT (LISP:CHAR-CODE
 #\0]
+                  [(<= (CONSTANT (LISP:CHAR-CODE
 #\A))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE
 #\Z)))
+                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE
 #\A]
+                  ((<= (CONSTANT (LISP:CHAR-CODE
 #\a))
+                       CODE
+                       (CONSTANT (LISP:CHAR-CODE
 #\z)))
+                   (+ 10 (- CODE (CONSTANT (LISP:CHAR-CODE
 #\a]
+         (AND VAL (< VAL RADIX)
+              VAL)))
+
+(DEFOPTIMIZER LISP:CHAR-EQUAL
 (CHAR &REST MORE-CHARS)
+                                  (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
+                                      `[EQ (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
+                                           (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

+                                                                    ,(CAR MORE-CHARS]
+                                      'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:CHAR-GREATERP
 (CHAR &REST MORE-CHARS)
+                                     `(> (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
+                                         ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                   (FORM)
+                                                                   `(%%CHAR-UPCASE-CODE

+                                                                     (LISP:CHAR-CODE
 ,FORM]
+                                                  MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-LESSP
 (CHAR &REST MORE-CHARS)
+                                  `(< (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
+                                      ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                (FORM)
+                                                                `(%%CHAR-UPCASE-CODE

+                                                                  (LISP:CHAR-CODE
 ,FORM]
+                                               MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-EQUAL
 (CHAR &REST MORE-CHARS)
+                                      (LISP:IF (EQL 1 (LISP:LENGTH MORE-CHARS))
+                                          `[NOT (EQ (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE

+                                                                             ,CHAR))
+                                                    (%%CHAR-UPCASE-CODE

+                                                     (LISP:CHAR-CODE
 ,(CAR MORE-CHARS]
+                                          'COMPILER:PASS))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-GREATERP
 (CHAR &REST MORE-CHARS)
+                                         `(<=
+                                           (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
+                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                     (FORM)
+                                                                     `(%%CHAR-UPCASE-CODE

+                                                                       (LISP:CHAR-CODE

+                                                                        ,FORM]
+                                                    MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR-NOT-LESSP
 (CHAR &REST MORE-CHARS)
+                                      `(>= (%%CHAR-UPCASE-CODE
 (LISP:CHAR-CODE
 ,CHAR))
+                                           ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA
+                                                                     (FORM)
+                                                                     `(%%CHAR-UPCASE-CODE

+                                                                       (LISP:CHAR-CODE

+                                                                        ,FORM]
+                                                    MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR/=
 (CHAR &REST MORE-CHARS)
+                              (LISP:IF (CDR MORE-CHARS)
+                                  'COMPILER:PASS
+                                  `(NEQ ,CHAR ,(CAR MORE-CHARS))))
+
+(DEFOPTIMIZER LISP:CHAR<
 (CHAR &REST MORE-CHARS)
+                             `(< (LISP:CHAR-CODE
 ,CHAR)
+                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                 `(LISP:CHAR-CODE
 ,FORM]
+                                          MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR<=
 (CHAR &REST MORE-CHARS)
+                              `(<= (LISP:CHAR-CODE
 ,CHAR)
+                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                   `(LISP:CHAR-CODE
 ,FORM]
+                                            MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR=
 (CHAR &REST MORE-CHARS)
+                             (LISP:IF (CDR MORE-CHARS)
+                                 [LET
+                                  ((CH (GENSYM)))
+                                  `(LET ((,CH ,CHAR))
+                                        (AND ,@(for
 X in
 MORE-CHARS
+                                                  collect
 `(EQ ,CH ,X]
+                                 `(EQ ,CHAR ,(CAR MORE-CHARS))))
+
+(DEFOPTIMIZER LISP:CHAR>
 (CHAR &REST MORE-CHARS)
+                             `(> (LISP:CHAR-CODE
 ,CHAR)
+                                 ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                 `(LISP:CHAR-CODE
 ,FORM]
+                                          MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHAR>=
 (CHAR &REST MORE-CHARS)
+                              `(>= (LISP:CHAR-CODE
 ,CHAR)
+                                   ,@(LISP:MAPCAR [FUNCTION (LISP:LAMBDA (FORM)
+                                                                   `(LISP:CHAR-CODE
 ,FORM]
+                                            MORE-CHARS)))
+
+(DEFOPTIMIZER LISP:CHARACTERP
 (OBJECT)
+                                  `(TYPENAMEP ,OBJECT 'CHARACTER))
+
+(DEFOPTIMIZER LISP:LOWER-CASE-P
 (CHAR)
+                                    `(<= (CONSTANT (LISP:CHAR-CODE
 #\a))
+                                         (LISP:CHAR-CODE
 ,CHAR)
+                                         (CONSTANT (LISP:CHAR-CODE
 #\z))))
+
+(DEFOPTIMIZER LISP:STRING-CHAR-P
 (CHAR)
+                                     `(\DTEST ,CHAR 'CHARACTER))
+
+(DEFOPTIMIZER LISP:UPPER-CASE-P
 (CHAR)
+                                    `(<= (CONSTANT (LISP:CHAR-CODE
 #\A))
+                                         (LISP:CHAR-CODE
 ,CHAR)
+                                         (CONSTANT (LISP:CHAR-CODE
 #\Z))))
+
+
+
+(* ;; "Internals")

+
+
+(DEFMACRO %%CHAR-DOWNCASE-CODE
 (CODE)
+   `(LET ((%%CODE ,CODE))
+         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE
 #\A))
+                      %%CODE
+                      (CONSTANT (LISP:CHAR-CODE
 #\Z)))
+             [+ %%CODE (- (CONSTANT (LISP:CHAR-CODE
 #\a))
+                          (CONSTANT (LISP:CHAR-CODE
 #\A]
+             %%CODE)))
+
+(DEFMACRO %%CHAR-UPCASE-CODE
 (CODE)
+   `(LET ((%%CODE ,CODE))
+         (LISP:IF (<= (CONSTANT (LISP:CHAR-CODE
 #\a))
+                      %%CODE
+                      (CONSTANT (LISP:CHAR-CODE
 #\z)))
+             [- %%CODE (- (CONSTANT (LISP:CHAR-CODE
 #\a))
+                          (CONSTANT (LISP:CHAR-CODE
 #\A]
+             %%CODE)))
+
+(DEFMACRO %%CODE-CHAR
 (CODE)
+   `(\VAG2 \CHARHI ,CODE))
+
+
+
+(* ;; "Compiler options")

+
+
+(PUTPROPS CMLCHARACTER
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
+)
+(PRETTYCOMPRINT CMLCHARACTERCOMS)
+
+(RPAQQ CMLCHARACTERCOMS

+       [(COMS                                                (* ; 
+
                                         "Interlisp CHARCODE; Some is here, the rest is in LLREAD.")

+              (FNS CHARCODE CHARCODE.UNDECODE)
+              (PROP MACRO SELCHARQ ALPHACHARP DIGITCHARP UCASECODE)
+              (OPTIMIZERS CHARCODE)
+              (ALISTS (DWIMEQUIVLST SELCHARQ)
+                     (PRETTYEQUIVLST SELCHARQ)))
+        (COMS                                                (* ; "Common Lisp CHARACTER type")

+              (DECLARE%: EVAL@COMPILE DONTCOPY (RECORDS CHARACTER))
+              (VARIABLES \CHARHI)
+              (VARIABLES LISP:CHAR-BITS-LIMIT LISP:CHAR-CODE-LIMIT LISP:CHAR-CONTROL-BIT 
+                     LISP:CHAR-FONT-LIMIT LISP:CHAR-HYPER-BIT LISP:CHAR-META-BIT LISP:CHAR-SUPER-BIT)
+              )
+        (COMS                                                (* ; "Basic character fns")

+              (FNS LISP:CHAR-CODE LISP:CHAR-INT LISP:INT-CHAR)
+              (FUNCTIONS LISP:CODE-CHAR)
+              (OPTIMIZERS LISP:CHAR-CODE LISP:CHAR-INT LISP:CODE-CHAR LISP:INT-CHAR))
+        [COMS                                                (* ; 
+
                                                        "I/O; Some is here, the rest is in LLREAD.")

+              (FNS CHARACTER.PRINT)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (SETTOPVAL (\TYPEGLOBALVARIABLE 'CHARACTER T)
+                                                        (NTYPX (LISP:CODE-CHAR 0 0 0)))
+                                                 (DEFPRINT 'CHARACTER 'CHARACTER.PRINT]
+        (COMS 
+              (* ;; "Common lisp character functions")

+
+              (FNS LISP:CHAR-BIT LISP:CHAR-BITS LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-NAME 
+                   LISP:CHAR-UPCASE LISP:CHARACTER LISP:NAME-CHAR LISP:SET-CHAR-BIT)
+              (FUNCTIONS LISP:DIGIT-CHAR LISP:MAKE-CHAR LISP::BASE-CHARACTER-P 
+                     LISP::EXTENDED-CHARACTER-P)
+              (OPTIMIZERS LISP:CHAR-UPCASE LISP:CHAR-DOWNCASE LISP:MAKE-CHAR))
+        (COMS 
+              (* ;; "Predicates")

+
+              (FNS LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHARACTERP 
+                   LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                   LISP:UPPER-CASE-P)
+              (FNS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                   LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                   LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+              (FUNCTIONS LISP:DIGIT-CHAR-P)
+              (OPTIMIZERS LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                     LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                     LISP:CHAR= LISP:CHAR> LISP:CHAR>= LISP:CHARACTERP LISP:LOWER-CASE-P 
+                     LISP:STRING-CHAR-P LISP:UPPER-CASE-P))
+        (COMS 
+              (* ;; "Internals")

+
+              (FUNCTIONS %%CHAR-DOWNCASE-CODE %%CHAR-UPCASE-CODE %%CODE-CHAR))
+        (COMS 
+              (* ;; "Compiler options")

+
+              (PROP FILETYPE CMLCHARACTER)
+              (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T)))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML CHARCODE)
+                      (LAMA LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                            LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                            LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL])
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 CHARCODE)
+
+(ADDTOVAR LAMA
 LISP:CHAR>= LISP:CHAR> LISP:CHAR= LISP:CHAR<= LISP:CHAR< LISP:CHAR/= 
+                         LISP:CHAR-NOT-LESSP LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-EQUAL 
+                         LISP:CHAR-LESSP LISP:CHAR-GREATERP LISP:CHAR-EQUAL)
+)
+(PUTPROPS CMLCHARACTER COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (4234 4520 (CHARCODE 4244 . 4303) (CHARCODE.UNDECODE 4305 . 4518)) (7120 7495 (
+LISP:CHAR-CODE 7130 . 7280) (LISP:CHAR-INT 7282 . 7348) (LISP:INT-CHAR 7350 . 7493)) (10135 11239 (
+CHARACTER.PRINT 10145 . 11237)) (11454 15081 (LISP:CHAR-BIT 11464 . 11621) (LISP:CHAR-BITS 11623 . 
+11784) (LISP:CHAR-DOWNCASE 11786 . 11976) (LISP:CHAR-FONT 11978 . 12139) (LISP:CHAR-NAME 12141 . 13934
+) (LISP:CHAR-UPCASE 13936 . 14122) (LISP:CHARACTER 14124 . 14670) (LISP:NAME-CHAR 14672 . 14916) (
+LISP:SET-CHAR-BIT 14918 . 15079)) (17155 20389 (LISP:ALPHA-CHAR-P 17165 . 17711) (LISP:ALPHANUMERICP 
+17713 . 17913) (LISP:BOTH-CASE-P 17915 . 18028) (LISP:CHARACTERP 18030 . 18176) (LISP:GRAPHIC-CHAR-P 
+18178 . 19317) (LISP:LOWER-CASE-P 19319 . 19480) (LISP:STANDARD-CHAR-P 19482 . 20152) (LISP:STRING-CHAR-P
+ 20154 . 20224) (LISP:UPPER-CASE-P 20226 . 20387)) (20390 26570 (LISP:CHAR-EQUAL 20400 . 20818) (
+LISP:CHAR-GREATERP 20820 . 21353) (LISP:CHAR-LESSP 21355 . 21885) (LISP:CHAR-NOT-EQUAL 21887 . 22537) 
+(LISP:CHAR-NOT-GREATERP 22539 . 23077) (LISP:CHAR-NOT-LESSP 23079 . 23614) (LISP:CHAR/= 23616 . 24246)
+ (LISP:CHAR< 24248 . 24724) (LISP:CHAR<= 24726 . 25204) (LISP:CHAR= 25206 . 25610) (LISP:CHAR> 25612
+ . 26088) (LISP:CHAR>= 26090 . 26568)))))
+STOP

CLTL2/CMLCOMPILE

@@ -0,0 +1,561 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 10:39:21" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;2"
 31069  
+
+      previous date%: "30-Mar-92 12:16:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLCOMPILE.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLCOMPILECOMS)
+
+(RPAQQ CMLCOMPILECOMS

+       [(COMS (FUNCTIONS LISP:DISASSEMBLE)
+              (FNS FAKE-COMPILE-FILE INTERLISP-FORMAT-P INTERLISP-NLAMBDA-FUNCTION-P 
+                   COMPILE-FILE-EXPRESSION COMPILE-FILE-WALK-FUNCTION ARGTYPE.STATE 
+                   COMPILE.CHECK.ARGTYPE COMPILE.FILE.DEFINEQ COMPILE-FILE-SETF-SYMBOL-FUNCTION 
+                   COMPILE-FILE-EX/IMPORT COMPILE.FILE.APPLY COMPILE.FILE.RESET COMPILE-IN-CORE)
+              (FNS COMPILE-FILE-SCAN-FIRST)
+                                                             (* ; 
+
                                                           "This function is support for AR#11185")

+              (VARS ARGTYPE.VARS)
+              (PROP COMPILE-FILE-EXPRESSION DEFINEQ * SETF-SYMBOL-FUNCTION PRETTYCOMPRINT)
+              (FUNCTIONS COMPILE-FILE-DECLARE%:))
+        [COMS (FNS NEWDEFC)
+              (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD 'NEWDEFC 'DEFC]
+        (PROP FILETYPE CMLCOMPILE)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA FAKE-COMPILE-FILE])
+
+(LISP:DEFUN LISP:DISASSEMBLE
 (NAME-OR-COMPILED-FUNCTION &KEY LEVEL-P (RADIX 8)
+                                        (OUTPUT *STANDARD-OUTPUT*)
+                                        FIRST-BYTE MARKED-PC)
+   (PRINTCODE (if
 (CCODEP NAME-OR-COMPILED-FUNCTION)
+                  then
 NAME-OR-COMPILED-FUNCTION
+                else
 (LISP:COMPILE NIL (if
 (LISP:SYMBOLP NAME-OR-COMPILED-FUNCTION)
+                                                 then
 (LISP:SYMBOL-FUNCTION 
+                                                                 NAME-OR-COMPILED-FUNCTION)
+                                               else
 NAME-OR-COMPILED-FUNCTION)))
+          LEVEL-P RADIX OUTPUT FIRST-BYTE MARKED-PC))
+(DEFINEQ
+
+(FAKE-COMPILE-FILE

+  (LISP:LAMBDA
+   (FILENAME &KEY LAP REDEFINE OUTPUT-FILE (SAVE-EXPRS T)
+          (COMPILER-OUTPUT T)
+          (PROCESS-ENTIRE-FILE NIL PEFP))                  (* ; "Edited 29-Jun-90 19:19 by nm")

+   (LET
+    (COMPILE.FILE.AFTER VALUE COMPILE.FILE.VALUE (NLAML NLAML)
+           (NLAMA NLAMA)
+           (LAMS LAMS)
+           (LAMA LAMA)
+           (DFNFLG NIL))
+    (DECLARE
 (LISP:SPECIAL COMPILE.FILE.AFTER COMPILE.FILE.VALUE NLAML NLAMA LAMS LAMA DFNFLG))
+    (RESETLST
+        (RESETSAVE NIL (LIST 'RESETUNDO)
+               (RESETUNDO))
+        (RESETSAVE COUTFILE COMPILER-OUTPUT)
+        (RESETSAVE STRF REDEFINE)
+        (RESETSAVE SVFLG (AND SAVE-EXPRS REDEFINE 'DEFER))
+        (RESETSAVE LAPFLG LAP)
+        (LET
+         ((*PACKAGE* *INTERLISP-PACKAGE*)
+          (*READ-BASE* 10)
+          (LOCALVARS SYSLOCALVARS)
+          (SPECVARS T)
+          STREAM LSTFIL ROOTNAME INTERLISP-FORMAT ENV FORM)
+         (DECLARE
 (LISP:SPECIAL *PACKAGE* *READ-BASE* LOCALVARS SPECVARS LSTFIL))
+         [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
+                                (SETQ STREAM (OPENSTREAM FILENAME 'INPUT]
+         (LISP:MULTIPLE-VALUE-SETQ (ENV FORM)
+                (\PARSE-FILE-HEADER STREAM 'RETURN T))
+         (SETQ INTERLISP-FORMAT (AND ENV (NEQ ENV *COMMON-LISP-READ-ENVIRONMENT*)))
+         (if
 (NOT PEFP)
+             then
 (SETQ PROCESS-ENTIRE-FILE INTERLISP-FORMAT))
+         (if
 LAP
+             then
 (SETQ LSTFIL COUTFILE))
+         (SETQ FILENAME (FULLNAME STREAM))
+         (RESETSAVE NIL (LIST (FUNCTION COMPILE.FILE.RESET)
+                                [SETQ OUTPUT-FILE (OPENSTREAM (OR OUTPUT-FILE (PACKFILENAME.STRING
+                                                                               'VERSION NIL
+                                                                               'EXTENSION COMPILE.EXT
+                                                                               'BODY FILENAME))
+                                                         'OUTPUT
+                                                         'NEW
+                                                         '((TYPE BINARY]
+                                STREAM
+                                (ROOTFILENAME FILENAME)))
+         (if
 OUTPUT-FILE
+             then
 (RESETSAVE LCFIL OUTPUT-FILE)
+                   (PRINT-COMPILE-HEADER (LIST STREAM)
+                          '("COMPILE-FILEd")
+                          ENV))
+         (WITH-READER-ENVIRONMENT ENV
+             (PROG ((DEFERRED.EXPRESSIONS NIL)
+                    (*PRINT-ARRAY* T)
+                    (*PRINT-LEVEL* NIL)
+                    (*PRINT-LENGTH* NIL)
+                    (FIRSTFORMS NIL)
+                    (AFTERS NIL)
+                    (SCRATCH.LCOM '{CORE}SCRATCH.LCOM)
+                    DUMMYFILE TEMPVAL)
+                   (DECLARE
 (LISP:SPECIAL DEFERRED.EXPRESSIONS *PRINT-ARRAY* *PRINT-LEVEL* 
+                                       *PRINT-LENGTH* FIRSTFORMS AFTERS DEFERS))
+                                                             (* ; "Edited by TT (11-June-90 : for AR#11185) all contents of file are read, and each forms are compiled.(This reading method is for supporting %"FIRST%", %"NOTFIRST%" tag.)")

+                   [RESETSAVE NIL (LIST (FUNCTION CLOSEF?)
+                                          (SETQ DUMMYFILE (OPENSTREAM SCRATCH.LCOM 'BOTH 'NEW]
+               LPDUMP
+                   [if
 (EQUAL (CAR FORM)
+                                  'RPAQQ)
+                       then
                              (* ; 
+
                                  "This is the support method of %"COMPILERVARS%" (2-July-1990 TT)")

+                             (SETQ TEMPVAL (CADDR FORM))
+                             (if
 (SETQ TEMPVAL (ASSOC 'DECLARE%: TEMPVAL))
+                                 then
 (if
 (SETQ TEMPVAL (FMEMB 'COMPILERVARS
+                                                                       (FMEMB 'DOEVAL@COMPILE TEMPVAL
+                                                                              )))
+                                              then
 (SETQ DFNFLG T)
+                                                    (if
 [SETQ TEMPVAL (FMEMB 'ADDVARS
+                                                                                 (SETQ TEMPVAL
+                                                                                  (CADR TEMPVAL]
+                                                        then
 (LISP:DOLIST (ARG (CDR TEMPVAL))
+                                                                     (APPLY 'ADDTOVAR ARG))]
+                   (COMPILE-FILE-EXPRESSION
 FORM DUMMYFILE NIL PROCESS-ENTIRE-FILE)
+                   (SKIPSEPRCODES STREAM)
+                   (if
 (EOFP STREAM)
+                       then
 (CLOSEF STREAM)
+                             (for
 FORM in
 FIRSTFORMS
+                                do
 (COMPILE-FILE-EXPRESSION
 FORM OUTPUT-FILE NIL 
+                                              PROCESS-ENTIRE-FILE T))
+                             (COPYBYTES DUMMYFILE OUTPUT-FILE 0 (GETFILEPTR DUMMYFILE))
+                             (CLOSEF? DUMMYFILE)
+                             (DELFILE (FULLNAME DUMMYFILE))
+                             (AND PROCESS-ENTIRE-FILE (for
 EXP in
 (REVERSE 
+                                                                                 DEFERRED.EXPRESSIONS
+                                                                                 )
+                                                         do
 (APPLY* (CAR EXP)
+                                                                       (CDR EXP)
+                                                                       OUTPUT-FILE)))
+                             (for
 FORM in
 AFTERS do
 (COMPILE-FILE-EXPRESSION
 FORM 
+                                                                       OUTPUT-FILE NIL 
+                                                                       PROCESS-ENTIRE-FILE T))
+                             (RETURN))
+                   (SETQ FORM (READ STREAM))
+                   (GO LPDUMP))
+             (PRINT NIL OUTPUT-FILE))
+         (SETQ COMPILE.FILE.VALUE (CLOSEF OUTPUT-FILE))))    (* ; 
+
                                                           "Do these after UNDONLSETQ entered")

+    (MAPC (REVERSE COMPILE.FILE.AFTER)
+          (FUNCTION EVAL))
+    COMPILE.FILE.VALUE)))
+
+(INTERLISP-FORMAT-P

+  [LAMBDA (STREAM)                                           (* bvm%: " 3-Aug-86 14:01")

+    (SELCHARQ (PEEKCCODE STREAM)
+         (; NIL)
+         ((^F "(") 
+              T)
+         NIL])
+
+(INTERLISP-NLAMBDA-FUNCTION-P

+  [LAMBDA (X)                                                (* lmm " 7-May-86 20:12")

+    (AND (LITATOM X)
+         (FMEMB (ARGTYPE X)
+                '(1 3))
+         (NOT (LISP:SPECIAL-FORM-P X])
+
+(COMPILE-FILE-EXPRESSION

+  [LAMBDA (FORM COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
+                                                             (* ; "Edited 30-Jun-90 18:31 by nm")

+    (DECLARE
 (LISP:SPECIAL COMPILED.FILE))
+    (AND (LISTP FORM)
+         (SELECTQ (CAR FORM)
+             ((DECLARE%: FILECREATED) 
+                  (COMPILE-FILE-SCAN-FIRST
 FORM COMPILED.FILE NIL T COMPILE.TIME.TOO DEFER 
+                         FORCE-OUTPUT-P))
+             ((DEFMACRO) 
+                  (LET* ((DEFINITION (REMOVE-COMMENTS FORM))
+                         (NAME (XCL::%%DEFINER-NAME 'DEFMACRO DEFINITION))
+                         (BODY (XCL::%%EXPAND-DEFINER 'DEFMACRO DEFINITION)))
+                        (LISP:EVAL BODY)
+                        (COMPILE-FILE-EXPRESSION
 BODY COMPILED.FILE COMPILE.TIME.TOO DEFER 
+                               FORCE-OUTPUT-P)))
+             ((PROGN) 
+                  (for
 X in
 (CDR FORM) do
 (COMPILE-FILE-EXPRESSION
 X COMPILED.FILE 
+                                                             COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)))
+             ((QUOTE)                                        (* ; 
+
                                                           " ignore top level quoted expression -i")

+                  NIL)
+             ((LISP:COMPILER-LET)                            (* ; " top level compiler-let. bind variables and recursively compile sub-expressions. This is here mainly  for b PCL has top level compiler-lets")

+                  [LET [(VARS (LISP:MAPCAR #'(LISP:LAMBDA (X)
+                                                    (if
 (LISP:CONSP X)
+                                                        then
 (CAR X)
+                                                      else
 X))
+                                     (CADR FORM)))
+                        (VALS (LISP:MAPCAR #'[LISP:LAMBDA (X)
+                                                    (if
 (LISP:CONSP X)
+                                                        then
 (LISP:EVAL (CADR X]
+                                     (CADR FORM]
+                       (LISP:PROGV VARS VALS
+                           (LISP:MAPC #'(LISP:LAMBDA (X)
+                                               (COMPILE-FILE-EXPRESSION
 X COMPILED.FILE 
+                                                      COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
+                                  (CDDR FORM)))])
+             ((LISP:EVAL-WHEN) 
+                  [LET [[EVAL.SPECIFIED (OR (FMEMB 'EVAL (CADR FORM))
+                                            (FMEMB 'LISP:EVAL (CADR FORM]
+                        [LOAD.SPECIFIED (OR (FMEMB 'LOAD (CADR FORM))
+                                            (FMEMB 'LISP:LOAD (CADR FORM]
+                        (COMPILE.SPECIFIED (OR (FMEMB 'COMPILE (CADR FORM))
+                                               (FMEMB 'LISP:COMPILE (CADR FORM]
+                       (COND
+                          [(NOT LOAD.SPECIFIED)
+                           (COND
+                              ((OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO EVAL.SPECIFIED))
+                               (for
 INNER-FORM in
 (CDDR FORM) do
 (EVAL INNER-FORM]
+                          (T (for
 INNER-FORM in
 (CDDR FORM)
+                                do
 (COMPILE-FILE-EXPRESSION
 INNER-FORM COMPILED.FILE
+                                              (OR COMPILE.SPECIFIED (AND COMPILE.TIME.TOO 
+                                                                         EVAL.SPECIFIED))
+                                              DEFER FORCE-OUTPUT-P])
+             ((LISP:IN-PACKAGE LISP:IN-PACKAGE)              (* ; 
+
        "These are special because they have to be dumped to the output BEFORE the package changes")

+                  (PRINT FORM COMPILED.FILE)
+                  (EVAL FORM))
+             ((LISP:MAKE-PACKAGE LISP:SHADOW LISP:SHADOWING-IMPORT EXPORT LISP:UNEXPORT 
+                     LISP:USE-PACKAGE LISP:UNUSE-PACKAGE IMPORT) 
+                                                             (* ; "This is Special also, becouse  the compiling Environment Must be changed.(see CLtL, 11.7. Package System Functions and Variables)  edited by TT(10-April-90)")

+                  (PRINT FORM COMPILED.FILE)
+                  (EVAL FORM))
+             ((LISP:SETQ)                                    (* ; 
+
           "Gasly kludge because cl:setq needs to run in the init before macroexpansion is enabled")

+                  (COMPILE-FILE-EXPRESSION
 (EXPANDMACRO FORM T)
+                         COMPILED.FILE COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P))
+             (LET [(PROP (OR (GETPROP (CAR FORM)
+                                    'COMPILE-FILE-EXPRESSION)
+                             (GETPROP (CAR FORM)
+                                    'COMPILE.FILE.EXPRESSION]
+                  (if
 [AND (NOT PROP)
+                               (NOT (LISP:SPECIAL-FORM-P (CAR FORM)))
+                               (NOT (INTERLISP-NLAMBDA-FUNCTION-P
 (CAR FORM)))
+                               (NEQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM]
+                      then
 (COMPILE-FILE-EXPRESSION
 FORM COMPILED.FILE COMPILE.TIME.TOO DEFER
+                                      FORCE-OUTPUT-P)
+                    else
 (if
 COMPILE.TIME.TOO
+                                 then
 (EVAL FORM))
+                          (if
 PROP
+                              then
 (COMPILE.FILE.APPLY
 PROP FORM DEFER FORCE-OUTPUT-P)
+                            elseif
 [NOT (EQUAL FORM (SETQ FORM (WALK-FORM FORM :WALK-FUNCTION
+                                                                          (FUNCTION 
+                                                                           COMPILE-FILE-WALK-FUNCTION
+                                                                           ]
+                              then
 (COMPILE-FILE-EXPRESSION
 FORM COMPILED.FILE 
+                                              COMPILE.TIME.TOO DEFER FORCE-OUTPUT-P)
+                            else
 (COMPILE.FILE.APPLY
 (FUNCTION PRINT)
+                                            FORM DEFER FORCE-OUTPUT-P])
+
+(COMPILE-FILE-WALK-FUNCTION

+  [LAMBDA (FORM)                                             (* lmm "26-Jun-86 17:25")

+    (if
 (NLISTP FORM)
+        then
 FORM
+      else
 (LISP:VALUES FORM (INTERLISP-NLAMBDA-FUNCTION-P
 (CAR FORM])
+
+(ARGTYPE.STATE

+  [LAMBDA NIL
+    (for
 X in
 ARGTYPE.VARS do
 (PRINTOUT T X %, (EVAL (CADR X))
+                                                 T])
+
+(COMPILE.CHECK.ARGTYPE

+  [LAMBDA (X AT)                                             (* lmm "15-Jun-85 16:58")

+    (if
 (NEQ AT (LET (BLKFLG)
+                         (COMP.ARGTYPE X)))
+        then
                                             (* ; 
+
                                                         "Incorrectly on one of the defining lists")

+        (for
 ATYPEPAIR in
 ARGTYPE.VARS
+           do
 (LET [(VAL (FMEMB X (EVALV (CADR ATYPEPAIR]
+                       (if
 (EQ AT (CAR ATYPEPAIR))
+                           then
 (if
 VAL
+                                        then
 (PRINTOUT COUTFILE "Compiler confused: " X " on "
+                                                        (CADR ATYPEPAIR)
+                                                        " but compiler doesn't think its a "
+                                                        (CADDR ATYPEPAIR)))
+                                 [/SETTOPVAL (CADR ATYPEPAIR)
+                                        (CONS X (PROGN (GETTOPVAL (CADR ATYPEPAIR]
+                         else
 (if
 VAL
+                                      then
 (PRINTOUT COUTFILE "Warning: compiler thought " X " "
+                                                      (LIST 'a (OR (CADDR (ASSOC AT ARGTYPE.VARS))
+                                                                   "LAMBDA spread")
+                                                            'function)
+                                                      " was a "
+                                                      (CADDR ATYPEPAIR)
+                                                      " because it was incorrectly on "
+                                                      (CADR ATYPEPAIR)
+                                                      T)
+                                            (/SETTOPVAL (CADR ATYPEPAIR)
+                                                   (REMOVE X (PROGN (GETTOPVAL (CADR ATYPEPAIR])
+
+(COMPILE.FILE.DEFINEQ

+  [LAMBDA (FORM LCFIL)                                       (* bvm%: "18-Sep-86 14:35")

+    (for
 DEF in
 (CDR FORM) unless
 (FMEMB (CAR DEF)
+                                                     DONTCOMPILEFNS)
+       do
 (COMPILE.CHECK.ARGTYPE
 (CAR DEF)
+                     (ARGTYPE (CADR DEF)))
+             (BYTECOMPILE2 (CAR DEF)
+                    (COMPILE1A (CAR DEF)
+                           (CADR DEF)
+                           NIL])
+
+(COMPILE-FILE-SETF-SYMBOL-FUNCTION

+  [LAMBDA (FORM LCFIL)                                       (* bvm%: " 8-Sep-86 16:55")

+    (if
 [AND (FMEMB (CAR (LISTP (LISP:THIRD FORM)))
+                        '(FUNCTION LISP:FUNCTION))
+                 (EQ (CAR (LISTP (LISP:SECOND FORM)))
+                     'QUOTE)
+                 (LISP:CONSP (LISP:SECOND (LISP:THIRD FORM]
+        then
 (BYTECOMPILE2 (CADR (LISP:SECOND FORM))
+                        (CADR (LISP:THIRD FORM)))
+      else
 (PRINT (WALK-FORM FORM :WALK-FUNCTION (FUNCTION COMPILE-FILE-WALK-FUNCTION))
+                      LCFIL])
+
+(COMPILE-FILE-EX/IMPORT

+  [LAMBDA (FORM LCFIL RDTBL)                                 (* bvm%: " 3-Aug-86 15:05")

+
+         (* * "EXPORT, IMPORT, SHADOW, USE-PACKAGE are all implicitly EVAL@COMPILE, since they have to affect the package being used to read what follows")

+
+    (PRINT FORM LCFIL RDTBL)
+    (EVAL FORM])
+
+(COMPILE.FILE.APPLY

+  [LAMBDA (PROP FORM DEFER FORCE-OUTPUT-P)                   (* ; "Edited 29-Jun-90 19:21 by nm")

+    (if
 FORCE-OUTPUT-P
+        then
 (PRINT FORM COMPILED.FILE)
+      else
 (if
 DEFER
+                   then
 (push
 DEFERRED.EXPRESSIONS (CONS PROP FORM))
+                 else
 (APPLY* PROP FORM COMPILED.FILE])
+
+(COMPILE.FILE.RESET

+  [LAMBDA (COMPILED.FILE SOURCEFILE ROOTNAME)                (* bvm%: " 9-Sep-86 15:16")

+                                                             (* Cleans up after brecompile and 
+
                                                           bcompl have finished operating,)

+    (if
 (AND COMPILED.FILE (OPENP COMPILED.FILE))
+        then
 (CLOSE-AND-MAYBE-DELETE COMPILED.FILE))
+    (if
 SOURCEFILE
+        then
 (CLOSEF? SOURCEFILE))
+    (if
 (NULL RESETSTATE)
+        then
                                             (* Finished successfully.)

+              (/SETATOMVAL 'NOTCOMPILEDFILES (REMOVE ROOTNAME NOTCOMPILEDFILES)) 
+                                                             (* Removes FILES from 
+
                                                           NOTCOMPILEDFILES.)
])
+
+(COMPILE-IN-CORE

+  [LAMBDA (fn-name fn-expr fn-type NOSAVE)
+    (DECLARE
 (SPECVARS LCFIL LAPFLG STRF SVFLG LSTFIL SPECVARS LOCALVARS DONT-TRANSFER-PUTD))
+                                                             (* lmm " 2-Jun-86 22:04")

+
+         (* in-core compiling for functions and forms, without the interview.
+
       if X is a list, we assume that we are being called merely to display the lap 
+
       and machine code. the form is compiled as the definition of FOO but the 
+
       compiled :CODE is thrown away. -
+
       if X is a litatom, then saving, redefining, and printing is controlled by the 
+
       flags.)

+
+    (LET ((NOREDEFINE NIL)
+          (PRINTLAP NIL)
+          (DONT-TRANSFER-PUTD T))
+         (RESETVARS [(NLAMA NLAMA)
+                     (NLAML NLAML)
+                     (LAMS LAMS)
+                     (LAMA LAMA)
+                     (NOFIXFNSLST NOFIXFNSLST)
+                     (NOFIXVARSLST NOFIXVARSLST)
+                     (COUTFILE (COND
+                                  ((AND (BOUNDP 'NULLFILE)
+                                        (STREAMP NULLFILE)
+                                        (OPENP NULLFILE))
+                                   NULLFILE)
+                                  (T (SETQ NULLFILE (OPENFILE '{NULL} 'OUTPUT]
+                    (RETURN (RESETLST                        (* RESETLST to provide reset context 
+
                                                           for macros under COMPILE1 as 
+
                                                           generated e.g. by DECL.)

+                                [PROG ((LCFIL)
+                                       [LAPFLG (AND PRINTLAP (COND
+                                                                (BYTECOMPFLG T)
+                                                                (T 2]
+                                       (STRF (NOT NOREDEFINE))
+                                       (SVFLG (if
 (EQ fn-type 'SELECTOR)
+                                                  then
 'SELECTOR
+                                                else
 (NOT NOSAVE)))
+                                       (LSTFIL T)
+                                       (SPECVARS SYSSPECVARS)
+                                       (LOCALVARS T))
+                                      (RETURN (PROGN (SETQ fn-expr (COMPILE1A fn-name fn-expr T))
+                                                     (PROG ((FREEVARS FREEVARS))
+                                                           (RETURN (BYTECOMPILE2 fn-name fn-expr])])
+)
+(DEFINEQ
+
+(COMPILE-FILE-SCAN-FIRST

+  [LAMBDA (FORM COMPILED.FILE FIRSTFLG DOCOPY EVAL@COMPILE DEFER FORCE-OUTPUT-P)
+                                                             (* ; "Edited 30-Jun-90 18:32 by nm")

+                                                             (* ; "Edited 26-Apr-90 by tt")

+                                                             (* ; 
+
                      "This is enhancement for Fake Compiler's interpretation of file package coms")

+    (PROG ((DFNFLG DFNFLG)
+           (FIRST
 FIRSTFLG)
+           (DOCOPY DOCOPY)
+           (EVAL@COMPILE EVAL@COMPILE)
+           NOTFIRST)
+          (if
 (LISTP FORM)
+              then

+              (SELECTQ (CAR FORM)
+                  ((DECLARE%:) 
+                       (LISP:DO ((TAIL (CDR FORM)
+                                       (CDR TAIL)))
+                                ((LISP:ENDP TAIL))
+                           [if
 (LISP:SYMBOLP (CAR TAIL))
+                               then
 (CASE (CAR TAIL)
+                                            ((DOCOPY COPY) (SETQ DOCOPY T))
+                                            ((DONTCOPY) (SETQ DOCOPY NIL))
+                                            ((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL
+                                                                                 (CDR TAIL])
+                                            ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
+                                            ((EVAL@LOADWHEN) (LISP:POP TAIL))
+                                            ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
+                                            ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
+                                            ((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE
+                                                                 (EVAL (CAR (SETQ TAIL (CDR TAIL])
+                                            ((FIRST) 
+                                               (SETQ FIRST T)
+                                               (SETQ NOTFIRST NIL))
+                                                             (* ; "for First")

+                                            ((NOTFIRST) 
+                                               (SETQ NOTFIRST T)
+                                               (SETQ FIRST NIL))
+                                                             (* ; "for Not First")

+                                            ((COMPILERVARS) (SETQ DFNFLG T))
+                                                             (* ; "for Compilervars")

+                                            (LISP:OTHERWISE (LISP:FORMAT COUTFILE 
+                                                 "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
+                                                                   (CAR TAIL))))
+                             else
 (COND
+                                         ((EQ 'DECLARE%: (CAR (CAR TAIL)))
+                                          (COMPILE-FILE-SCAN-FIRST
 (CAR TAIL)
+                                                 COMPILED.FILE FIRST DOCOPY EVAL@COMPILE DEFER))
+                                         (T (LISP:WHEN EVAL@COMPILE
+                                                (EVAL (CAR TAIL)))
+                                            (LISP:WHEN DOCOPY
+                                                (LISP:IF FIRST
+                                                    (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS (CAR TAIL)))
+                                                    (LISP:IF NOTFIRST
+                                                        (SETQ AFTERS (NCONC1 AFTERS (CAR TAIL)))
+                                                        (COMPILE-FILE-EXPRESSION
 (CAR TAIL)
+                                                               COMPILED.FILE EVAL@COMPILE DEFER 
+                                                               FORCE-OUTPUT-P))))]))
+                  ((FILECREATED) 
+                       (if
 FORCE-OUTPUT-P
+                           then
 (PRINT FORM COMPILED.FILE)
+                         else
 (SETQ FIRSTFORMS (NCONC1 FIRSTFORMS FORM))))
+                  NIL])
+)
+
+
+
+(* ; "This function is support for AR#11185")

+
+
+(RPAQQ ARGTYPE.VARS
 ((1 NLAML "NLAMBDA spread")
+                         (2 LAMA "LAMBDA nospread")
+                         (0 LAMS "LAMBDA spread")
+                         (3 NLAMA "NLAMBDA no-spread")))
+
+(PUTPROPS DEFINEQ
 COMPILE-FILE-EXPRESSION
 COMPILE.FILE.DEFINEQ)
+
+(PUTPROPS *
 COMPILE-FILE-EXPRESSION
 NILL)
+
+(PUTPROPS SETF-SYMBOL-FUNCTION
 COMPILE-FILE-EXPRESSION
 COMPILE-FILE-SETF-SYMBOL-FUNCTION)
+
+(PUTPROPS PRETTYCOMPRINT
 COMPILE-FILE-EXPRESSION
 NILL)
+
+(LISP:DEFUN COMPILE-FILE-DECLARE%:
 (FORM COMPILED.FILE EVAL@COMPILE DOCOPY DEFER)
+   (LISP:DO ((TAIL (CDR FORM)
+                   (CDR TAIL)))
+            ((LISP:ENDP TAIL))
+       (LISP:IF (LISP:SYMBOLP (CAR TAIL))
+           (CASE (CAR TAIL)
+               ((EVAL@LOAD DOEVAL@LOAD DONTEVAL@LOAD) NIL)
+               ((EVAL@LOADWHEN) (LISP:POP TAIL))
+               ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL@COMPILE T))
+               ((DONTEVAL@COMPILE) (SETQ EVAL@COMPILE NIL))
+               ((EVAL@COMPILEWHEN) [SETQ EVAL@COMPILE (EVAL (CAR (SETQ TAIL (CDR TAIL])
+               ((COPY DOCOPY) (SETQ DOCOPY T))
+               ((DONTCOPY) (SETQ DOCOPY NIL))
+               ((COPYWHEN) [SETQ DOCOPY (EVAL (CAR (SETQ TAIL (CDR TAIL])
+               ((FIRST) )
+               ((NOTFIRST COMPILERVARS) )
+               (LISP:OTHERWISE (LISP:FORMAT COUTFILE 
+                                      "Warning: Ignoring unrecognized DECLARE: tag: ~S~%%"
+                                      (CAR TAIL))))
+           [COND
+              ((EQ 'DECLARE%: (CAR (CAR TAIL)))
+               (COMPILE-FILE-DECLARE%:
 (CAR TAIL)
+                      COMPILED.FILE EVAL@COMPILE DOCOPY DEFER))
+              (T (LISP:WHEN EVAL@COMPILE
+                     (EVAL (CAR TAIL)))
+                 (LISP:WHEN DOCOPY
+                     (COMPILE-FILE-EXPRESSION
 (CAR TAIL)
+                            COMPILED.FILE EVAL@COMPILE DEFER))])))
+(DEFINEQ
+
+(NEWDEFC

+  [LAMBDA (NM DF)                                            (* bvm%: "30-Sep-86 23:12")

+    [COND
+       ((EQ SVFLG 'DEFER)
+        (push
 COMPILE.FILE.AFTER (LIST (FUNCTION NEWDEFC)
+                                           (KWOTE NM)
+                                           (KWOTE DF)
+                                           T)))
+       ((OR (NULL DFNFLG)
+            (EQ DFNFLG T))
+        [COND
+           ((GETD NM)
+            (VIRGINFN NM T)
+            (COND
+               ((NULL DFNFLG)
+                (LISP:FORMAT *ERROR-OUTPUT* "~&(~S redefined)~%%" NM)
+                (SAVEDEF NM]
+        (/PUTD NM DF T))
+       (T 
+          (* ;; "Save on CODE prop.  Be nice and change it from archaic CCODEP object to modern compiled code object.")

+
+          (/PUTPROP NM 'CODE (if
 (ARRAYP DF)
+                                 then
 (create
 COMPILED-CLOSURE
+                                                 FNHEADER _ (fetch
 (ARRAYP BASE) of
 DF))
+                               else
 DF]
+    DF])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD 'NEWDEFC 'DEFC)
+)
+
+(PUTPROPS CMLCOMPILE
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 FAKE-COMPILE-FILE)
+)
+(PUTPROPS CMLCOMPILE COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (2394 23384 (FAKE-COMPILE-FILE 2404 . 8967) (INTERLISP-FORMAT-P 8969 . 9191) (
+INTERLISP-NLAMBDA-FUNCTION-P 9193 . 9429) (COMPILE-FILE-EXPRESSION 9431 . 15709) (
+COMPILE-FILE-WALK-FUNCTION 15711 . 15960) (ARGTYPE.STATE 15962 . 16124) (COMPILE.CHECK.ARGTYPE 16126
+ . 18118) (COMPILE.FILE.DEFINEQ 18120 . 18615) (COMPILE-FILE-SETF-SYMBOL-FUNCTION 18617 . 19227) (
+COMPILE-FILE-EX/IMPORT 19229 . 19557) (COMPILE.FILE.APPLY 19559 . 19921) (COMPILE.FILE.RESET 19923 . 
+20784) (COMPILE-IN-CORE 20786 . 23382)) (23385 27623 (COMPILE-FILE-SCAN-FIRST 23395 . 27621)) (29617 
+30683 (NEWDEFC 29627 . 30681)))))
+STOP

CLTL2/CMLDEFFER

@@ -0,0 +1,248 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+
(IL:FILECREATED "24-Mar-92 14:56:18" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;3|
 40644  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLDEFFERCOMS)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 15:32:26" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;2|)
+
+
+; Copyright (c) 1986, 1900, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLDEFFERCOMS)
+
+(IL:RPAQQ IL:CMLDEFFERCOMS ((IL:* IL:|;;;| "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.") (IL:* IL:|;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned.") (IL:* IL:|;;;| "Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init") (IL:COMS (IL:* IL:\; "Filepkg interface") (IL:FUNCTIONS REMOVE-COMMENTS PPRINT-DEFINER PPRINT-DEFINER-FITP PPRINT-DEFINER-RECURSE) (IL:VARIABLES IL:*REMOVE-INTERLISP-COMMENTS*) (IL:* IL:\; "Share with xcl?") (IL:FUNCTIONS %DEFINE-TYPE-DELDEF %DEFINE-TYPE-GETDEF %DEFINE-TYPE-FILE-DEFINITIONS %DEFINE-TYPE-FILEGETDEF %DEFINE-TYPE-SAVE-DEFN %DEFINE-TYPE-PUTDEF)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN)) (IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF)) (IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:* IL:|;;| "Set up fake definer prototype stuff for FNS") (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))) (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))))) (IL:COMS (IL:* IL:\; "The groundwork for bootstrapping ") (IL:DEFINE-TYPES IL:DEFINE-TYPES IL:FUNCTIONS IL:VARIABLES) (IL:* IL:\; "DefDefiner itself and friends") (IL:FUNCTIONS SI::EXPANSION-FUNCTION SI::MACRO-FUNCALL WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:FUNCTIONS IL:WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Some special forms") (IL:FUNCTIONS DEFINER DEFINER-VARIABLE-TYPE NAMED-PROGN)) (IL:COMS (IL:* IL:\; "Auxiliary functions") (IL:FUNCTIONS GET-DEFINER-NAME %DELETE-DEFINER) (IL:FUNCTIONS DEF-DEFINE-TYPE DEFDEFINER DEFDEFINER-VARIABLE-TYPE) (IL:FUNCTIONS %EXPAND-DEFINER %DEFINER-NAME)) (IL:COMS (IL:* IL:\; "The most commonly-used definers") (IL:FUNCTIONS DEFUN DEFINLINE DEFMACRO) (IL:FUNCTIONS DEFVAR DEFPARAMETER DEFCONSTANT DEFGLOBALVAR DEFGLOBALPARAMETER)) (IL:COMS (IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.") (IL:DEFINE-TYPES IL:SPECIAL-FORMS) (IL:FUNCTIONS %REMOVE-SPECIAL-FORM) (IL:FUNCTIONS DEFINE-SPECIAL-FORM) (IL:* IL:\; "Form for defining interpreters of special forms")) (IL:COMS (IL:* IL:\; "Don't note changes to these properties/variables") (IL:PROP IL:PROPTYPE IL:MACRO-FN :UNDEFINERS IL:UNDEFINERS :DEFINER-FOR IL:DEFINER-FOR :DEFINED-BY IL:DEFINED-BY :DEFINITION-NAME IL:DEFINITION-NAME) (IL:* IL:\; "Templates for definers not defined here.  These should really be where they're defined.") (IL:PROP :DEFINITION-PRINT-TEMPLATE DEFCOMMAND DEFINE-CONDITION DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD DEFSETF DEFSTRUCT DEFTYPE)) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLDEFFER)))
+
+
+
+(IL:* IL:|;;;| 
+"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.")

+
+
+
+
+(IL:* IL:|;;| 
+"BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned."
+)

+
+
+
+
+(IL:* IL:|;;;| 
+"Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init"
+)

+
+
+
+
+(IL:* IL:\; "Filepkg interface")

+
+
+(DEFUN REMOVE-COMMENTS (X) (IL:* IL:|;;;| "Removes SEdit-style comments from the given list structure.") (COND ((NOT (CONSP X)) X) ((AND (CONSP (CAR X)) (EQ (CAAR X) (QUOTE IL:*)) (CONSP (CDAR X)) (OR (MEMBER (CADAR X) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\|)) :TEST (FUNCTION EQ)) (IL:* IL:\; "a sedit comment") (EQ IL:*REMOVE-INTERLISP-COMMENTS* T) (IL:* IL:\; "always strip") (PROGN (IF (EQ IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN)) (WARN "Possible comment not stripped ~S" (CAR X))) NIL))) (REMOVE-COMMENTS (CDR X))) (T (LET ((A (REMOVE-COMMENTS (CAR X))) (D (REMOVE-COMMENTS (CDR X)))) (IF (AND (EQ A (CAR X)) (EQ D (CDR X))) X (CONS A D))))))
+
+(DEFUN PPRINT-DEFINER (DEFINE-EXPRESSION) (DECLARE (SPECIAL IL:FORMFLG IL:SPACEWIDTH)) (IL:* IL:\; "Bound in prettyprinter") (COND ((OR (NULL IL:FORMFLG) (ATOM (CDR DEFINE-EXPRESSION))) (IL:* IL:\; "Degenerate cases or printing as a quoted form--punt to default prettyprinting") DEFINE-EXPRESSION) (T (LET ((IL:TAIL DEFINE-EXPRESSION) (IL:LEFT (IL:DSPXPOSITION)) TEMPLATE TOP-LEVEL-P NEXT TYPE FORM NEWLINEP) (DECLARE (SPECIAL IL:TAIL IL:LEFT)) (IL:* IL:\; "For comment printer") (SETQ TOP-LEVEL-P (EQ IL:LEFT (IL:DSPLEFTMARGIN))) (IL:* IL:\; "Printing definition to file, etc.") (SETQ IL:LEFT (+ IL:LEFT (* 3 IL:SPACEWIDTH))) (IL:* IL:\; "Place we will indent body") (IL:PRIN1 "(") (IL:PRIN2 (CAR IL:TAIL)) (SETQ TEMPLATE (OR (GET (POP IL:TAIL) :DEFINITION-PRINT-TEMPLATE) (QUOTE (:NAME)))) (IL:* IL:|;;| "This code should, and doesn't, pay attention to the NAME function to determine where the name is to decide what should and shouldn't be bold. Right now, it always bolds the second thing. Fortunately, we currently don't have any definers that don't have either the second or CAR of the second as the definition name.") (IL:* IL:|;;| "Also, this code should be careful about calling the NAME function on the form.  Sometimes, the form is not really a call to the definer but instead a back-quoted expression in a macro.  In most such cases, the name is not really there; some comma-quoted expression is there instead.") (IL:WHILE (CONSP IL:TAIL) IL:DO (COND ((AND (LISTP (SETQ NEXT (CAR IL:TAIL))) (EQ (CAR NEXT) IL:COMMENTFLG) (IL:SEMI-COLON-COMMENT-P NEXT)) (IL:* IL:\; "Comments can appear anywhere, so print this one without consuming the template.  ENDLINE has side effect of printing comments") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T)) ((OR (ATOM TEMPLATE) (EQ (SETQ TYPE (POP TEMPLATE)) :BODY)) (IL:* IL:\; "Once we hit the body, there's nothing more special to do.") (RETURN)) (T (IL:SPACES 1) (CASE TYPE (:NAME (IL:* IL:\; "Embolden the name of this thing") (SETQ NEWLINEP NIL) (COND ((NOT TOP-LEVEL-P) (IL:* IL:\; "Nothing special here--could even be a backquoted thing") (PPRINT-DEFINER-RECURSE)) (T (POP IL:TAIL) (COND ((CONSP NEXT) (IL:* IL:\; "Name is a list.  Assume the real name is the car and the rest is an options list or something") (UNLESS (EQ (IL:DSPYPOSITION) (PROGN (IL:PRIN1 "(") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 (CAR NEXT) IL:.FONT IL:DEFAULTFONT) (IL:SPACES 1) (IL:PRINTDEF (CDR NEXT) T T T IL:FNSLST) (IL:PRIN1 ")") (IL:DSPYPOSITION))) (IL:* IL:\; "This thing took more than one line to print, so go to new line") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T))) (T (IL:* IL:\; "Atomic name is bold") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 NEXT IL:.FONT IL:DEFAULTFONT)))))) (:ARG-LIST (IL:* IL:\; "NEXT is some sort of argument list.  ") (COND ((NULL NEXT) (IL:* IL:\; "If NIL, be sure to print as ()") (IL:PRIN1 "()") (POP IL:TAIL)) (T (PPRINT-DEFINER-RECURSE))) (SETQ NEWLINEP NIL)) (T (IL:* IL:\; "Just print it, perhaps starting a new line") (UNLESS (OR NEWLINEP (PPRINT-DEFINER-FITP NEXT)) (IL:* IL:\; "Go to new line if getting crowded") (IL:PRINENDLINE IL:LEFT)) (PPRINT-DEFINER-RECURSE) (SETQ NEWLINEP NIL)))))) (IL:* IL:|;;| "We've now gotten to the end of stuff we know how to print.  Just prettyprint the rest") (UNLESS (NULL IL:TAIL) (COND (NEWLINEP (IL:* IL:\; "Already on new line")) ((OR (EQ TYPE :BODY) (NOT (PPRINT-DEFINER-FITP (CAR IL:TAIL)))) (IL:* IL:\; "Go to new line and indent a bit.  Always do this for the part matching &BODY, whether or not the prettyprinter thought that the remainder would \"fit\"") (IL:PRINENDLINE IL:LEFT NIL T)) (T (IL:SPACES 1))) (IL:WHILE (AND (CONSP IL:TAIL) (ATOM (SETQ FORM (CAR IL:TAIL)))) IL:DO (IL:* IL:|;;| "Print this doc string or whatever on its own line.  This is because otherwise the prettyprinter gets confused and tries to put the next thing after the string") (PPRINT-DEFINER-RECURSE) (WHEN (AND (KEYWORDP FORM) (CONSP IL:TAIL)) (IL:* IL:\; "Some sort of keyword-value pair stuff--print it on same line") (IL:SPACES 1) (PPRINT-DEFINER-RECURSE)) (WHEN (NULL IL:TAIL) (RETURN)) (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*)) (IL:PRINTDEF IL:TAIL T T T IL:FNSLST)) (IL:PRIN1 ")") NIL))))
+
+(DEFUN PPRINT-DEFINER-FITP (ITEM) (IL:* IL:|;;| "True if it won't look silly to try to print ITEM at current position instead of starting new line") (IF (CONSP ITEM) (OR (EQ (CAR ITEM) IL:COMMENTFLG) (AND (< (IL:COUNT ITEM) 20) (IL:FITP ITEM))) (< (+ (IL:DSPXPOSITION) (IL:STRINGWIDTH ITEM *STANDARD-OUTPUT*)) (IL:DSPRIGHTMARGIN))))
+
+(DEFUN PPRINT-DEFINER-RECURSE NIL (IL:* IL:|;;| "Print and pop the next element.  Prettyprinter uses the variable IL:TAIL for lookahead") (DECLARE (SPECIAL IL:TAIL)) (IL:SUPERPRINT (CAR IL:TAIL) IL:TAIL NIL *STANDARD-OUTPUT*) (SETQ IL:TAIL (CDR IL:TAIL)))
+
+(DEFVAR IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN) "Either NIL (don't) T (always do) or :WARN (don't and warn)")
+
+
+
+(IL:* IL:\; "Share with xcl?")

+
+
+(DEFUN %DEFINE-TYPE-DELDEF (NAME TYPE) (IL:* IL:|;;| "DELETE definition of definer-defined NAME as TYPE ") (UNDOABLY-SETF (DOCUMENTATION NAME TYPE) NIL) (LET* ((HT (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HT (GETHASH NAME HT)))) (AND HT (IL:/PUTHASH NAME NIL HT)) (DOLIST (FN (OR (GET TYPE (QUOTE :UNDEFINERS)) (GET TYPE (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) (DOLIST (FN (OR (GET (CAR DEFN) (QUOTE :UNDEFINERS)) (GET (CAR DEFN) (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) NAME))
+
+(DEFUN %DEFINE-TYPE-GETDEF (NAME TYPE OPTIONS) (IL:* IL:|;;| "GETDEF method for all definers.  The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.") (LET* ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HASH-TABLE (GETHASH NAME HASH-TABLE)))) (IF (TYPECASE OPTIONS (CONS (MEMBER (QUOTE IL:EDIT) OPTIONS :TEST (FUNCTION EQ))) (T (EQ OPTIONS (QUOTE IL:EDIT)))) (COPY-TREE DEFN) DEFN)))
+
+(DEFUN %DEFINE-TYPE-FILE-DEFINITIONS (TYPE NAMES) (IL:* IL:|;;| "get the definitions for NAMES suitable for printing on a file. Like GETDEF but checks.") (MAPCAR (FUNCTION (LAMBDA (NAME) (LET ((DEF (%DEFINE-TYPE-GETDEF NAME TYPE (QUOTE (IL:NOCOPY))))) (IF (NULL DEF) (ERROR (QUOTE IL:NO-SUCH-DEFINITION) :NAME NAME :TYPE TYPE) DEF)))) NAMES))
+
+(DEFUN %DEFINE-TYPE-FILEGETDEF (NAME TYPE SOURCE OPTIONS NOTFOUND) (LET ((VAL (IL:LOADFNS NIL SOURCE (QUOTE IL:GETDEF) (IL:* IL:|;;| "The bletcherous lambda form is require by the interface to loadfns (can't pass a closure)") (IL:BQUOTE (IL:LAMBDA (FIRST SECOND) (AND (MEMBER FIRST (QUOTE (IL:\\\, (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))))) :TEST (FUNCTION EQ)) (LET ((NAMER (OR (GET FIRST (QUOTE :DEFINITION-NAME)) (GET FIRST (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)))) (IF (EQ NAMER (QUOTE SECOND)) (EQUAL SECOND (QUOTE (IL:\\\, NAME))) (EQUAL (FUNCALL NAMER (REMOVE-COMMENTS (IL:READ))) (QUOTE (IL:\\\, NAME))))))))))) (COND ((EQ (CAAR VAL) (QUOTE IL:NOT-FOUND\:)) NOTFOUND) ((CDR VAL) (CONS (QUOTE PROGN) VAL)) (T (CAR VAL)))))
+
+(DEFUN %DEFINE-TYPE-SAVE-DEFN (NAME TYPE DEFINITION) (SETQ TYPE (IL:GETFILEPKGTYPE TYPE (QUOTE TYPE))) (LET ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*))) (WHEN (NULL HASH-TABLE) (WARN "Couldn't find a hash-table for ~S definitions.~%One will be created." TYPE) (SETQ HASH-TABLE (SETF (GETHASH TYPE *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL) :SIZE 50 :REHASH-SIZE 50)))) (LET ((OLD-DEFINITION (GETHASH NAME HASH-TABLE))) (UNLESS (EQUAL DEFINITION OLD-DEFINITION) (WHEN (AND OLD-DEFINITION (NOT (EQ IL:DFNFLG T))) (FORMAT *TERMINAL-IO* "~&New ~A definition for ~S~:[~; (but not installed)~].~%" TYPE NAME (MEMBER IL:DFNFLG (QUOTE (IL:PROP IL:ALLPROP)) :TEST (FUNCTION EQ)))) (IL:/PUTHASH NAME DEFINITION HASH-TABLE) (IL:MARKASCHANGED NAME TYPE (IF OLD-DEFINITION (QUOTE IL:CHANGED) (QUOTE IL:DEFINED)))))))
+
+(DEFUN %DEFINE-TYPE-PUTDEF (NAME TYPE DEFINITION REASON) (IF (NULL DEFINITION) (%DEFINE-TYPE-DELDEF NAME TYPE) (LET ((DEFN-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION))) (UNLESS (AND (CONSP DEFN-WITHOUT-COMMENTS) (MEMBER (CAR DEFN-WITHOUT-COMMENTS) (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))) :TEST (FUNCTION EQ)) (EQUAL NAME (FUNCALL (OR (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE :DEFINITION-NAME)) (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)) DEFN-WITHOUT-COMMENTS))) (SIGNAL (QUOTE IL:DEFINER-MISMATCH) :NAME NAME :TYPE TYPE :DEFINITION DEFINITION)) (SETQ DEFINITION (COPY-TREE DEFINITION)) (EVAL (IF IL:LISPXHIST (MAKE-UNDOABLE DEFINITION) DEFINITION)))))
+
+
+
+(IL:* IL:\; "Compatibility with old cmldeffer")

+
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF))
+
+(IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))
+)
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:* IL:|;;| "Set up fake definer prototype stuff for FNS")
+
+(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
+
+(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
+)
+
+
+
+(IL:* IL:\; "The groundwork for bootstrapping ")

+
+
+(DEF-DEFINE-TYPE IL:DEFINE-TYPES "Definition type")
+
+(DEF-DEFINE-TYPE IL:FUNCTIONS "Common Lisp functions/macros" :UNDEFINER IL:UNDOABLY-FMAKUNBOUND)
+
+(DEF-DEFINE-TYPE IL:VARIABLES "Common Lisp variables" :UNDEFINER UNDOABLY-MAKUNBOUND)
+
+
+
+(IL:* IL:\; "DefDefiner itself and friends")

+
+
+(DEFUN SI::EXPANSION-FUNCTION (NAME ARG-LIST BODY) (IL:* IL:|;;;| "Shared code between DEFMACRO and DEFDEFINER.  Takes the parts of a DEFMACRO and returns two values: a LAMBDA form for the expansion function, and the documentation string found, if any.") (MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (IL:PARSE-DEFMACRO ARG-LIST (QUOTE SI::$$MACRO-FORM) BODY NAME NIL :ENVIRONMENT (QUOTE SI::$$MACRO-ENVIRONMENT)) (VALUES (IL:BQUOTE (LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) (IL:\\\,@ PARSED-DECLARATIONS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY)))) PARSED-DOCSTRING)))
+
+(DEFMACRO SI::MACRO-FUNCALL (EXPANSION-FUNCTION MACRO-CALL ENV) (IL:* IL:|;;;| "Used by DEFDEFINER as a mechanism for delaying macro-expansion until after checking the value of DFNFLG.  The arguments (unevaluated) are a macro-expansion function and a call on that macro.  The call to MACRO-FUNCALL should expand into the result of expanding the given macro-call.") (FUNCALL EXPANSION-FUNCTION MACRO-CALL ENV))
+
+(DEFMACRO WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (IL:\\\,@ BODY)) (EVAL-WHEN (EVAL) (UNLESS (OR (EQ IL:DFNFLG (QUOTE IL:PROP)) (EQ IL:DFNFLG (QUOTE IL:ALLPROP))) (LET ((IL:FILEPKGFLG NIL) (IL:DFNFLG T)) (IL:\\\,@ BODY)))))))
+
+
+
+(IL:* IL:\; "Compatibility with old cmldeffer")

+
+
+(DEFMACRO IL:WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (WITHOUT-FILEPKG (IL:\\\,@ BODY))))
+
+
+
+(IL:* IL:\; "Some special forms")

+
+
+(DEFMACRO DEFINER (TYPE NAME DEFINITION &OPTIONAL ENV) (LET* ((EXPANDER (GET NAME :DEFINITION-EXPANDER)) (DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
+
+(DEFMACRO DEFINER-VARIABLE-TYPE (NAME DEFINITION &OPTIONAL ENV) (LET* ((DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (TYPE (FUNCALL (GET NAME :TYPE-DISCRIMINATOR) DEFINITION-WITHOUT-COMMENTS)) (EXPANDER (GETF (GET NAME :DEFINITION-EXPANDER) TYPE)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
+
+(DEFMACRO NAMED-PROGN (DEFINER NAME &REST FORMS) (IL:* IL:|;;| "Used by the compiler when processing definers") (IL:BQUOTE (PROGN (IL:\\\,@ FORMS) (QUOTE (IL:\\\, NAME)))))
+
+
+
+(IL:* IL:\; "Auxiliary functions")

+
+
+(DEFUN GET-DEFINER-NAME (DEFINER STRING) (VALUES (INTERN (CONCATENATE (QUOTE STRING) STRING (STRING DEFINER)) (SYMBOL-PACKAGE DEFINER))))
+
+(DEFUN %DELETE-DEFINER (NAME) (AND (SYMBOLP NAME) (LET ((TYPE (OR (GET NAME (QUOTE :DEFINER-FOR)) (GET NAME (QUOTE IL:DEFINER-FOR))))) (IL:/REMPROP NAME (QUOTE :DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE IL:DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE :DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE IL:DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE :DEFINITION-EXPANDER)) (WHEN TYPE (IF (GET TYPE (QUOTE :DEFINED-BY)) (IL:/PUTPROP TYPE (QUOTE :DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE :DEFINED-BY)))) (IL:/PUTPROP TYPE (QUOTE IL:DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE IL:DEFINED-BY))))) (IL:* IL:|;;| "need to remove the prototype function!") (LET* ((LOOKUP-TYPE (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST (FUNCTION EQ)))) (IL:/RPLACD LOOKUP-TYPE (REMOVE NAME (CDR LOOKUP-TYPE) :KEY (FUNCTION CAR))))))))
+
+(DEFDEFINER (DEF-DEFINE-TYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEF-DEFINE-TYPE (IL:\\\, NAME) "Description string")))))) IL:DEFINE-TYPES (NAME DESCRIPTION &KEY UNDEFINER &AUX (CHANGELST (INTERN (CONCATENATE (QUOTE STRING) "CHANGED" (STRING NAME) "LST") (SYMBOL-PACKAGE NAME)))) "Define NAME as a new definition type" (IL:* IL:|;;| "This definition is a clean interface to a hokey implementation.  It works even before the file package is loaded.") (IL:BQUOTE (PROGN (SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE IL:DEFINE-TYPES)) (QUOTE (IL:\\\, DESCRIPTION))) (PUSHNEW (QUOTE ((IL:\\\, NAME) X (IL:P IL:* (%DEFINE-TYPE-FILE-DEFINITIONS (QUOTE (IL:\\\, NAME)) (QUOTE X))))) IL:PRETTYDEFMACROS :TEST (QUOTE EQUAL)) (IL:* IL:|;;| "the information about a type in the file package is split up into a number of different places. PRETTYTYPELST contains a random amount: the changelist is the variable whose top level value contains the list of changed items, and the description is a string used by files? This is duplicated in the CL:DOCUMENTATION mechanism") (PUSHNEW (QUOTE ((IL:\\\, CHANGELST) (IL:\\\, NAME) (IL:\\\, DESCRIPTION))) IL:PRETTYTYPELST :TEST (QUOTE EQUAL)) (DEFGLOBALVAR (IL:\\\, CHANGELST) NIL) (IL:* IL:|;;| "the definition hash table is where the definitions are really stored. Create an entry for this type. Note that definitions are compared using CL:EQUAL so that names can be strings, lists, etc.") (UNLESS (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (QUOTE EQUAL) :SIZE 50 :REHASH-SIZE 50))) (PUSHNEW (QUOTE (IL:\\\, NAME)) IL:FILEPKGTYPES) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:GETDEF)) (QUOTE %DEFINE-TYPE-GETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:DELDEF)) (QUOTE %DEFINE-TYPE-DELDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:PUTDEF)) (QUOTE %DEFINE-TYPE-PUTDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEGETDEF)) (QUOTE %DEFINE-TYPE-FILEGETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEPKGCONTENTS)) (QUOTE IL:NILL)) (IL:\\\,@ (WHEN UNDEFINER (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, UNDEFINER)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS))))))))))
+
+(DEFDEFINER (DEFDEFINER (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (QUOTE IL:SEDIT)) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPE ARG-LIST &BODY BODY) (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINER NIL) (PROTOTYPE-FN NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINER) (SETQ UNDEFINER (CADR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPE) (SETQ PROTOTYPE-FN (CADR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST BODY) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME "definition-expander-")) (NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-")))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPE))) (PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (AND UNDEFINER (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME "undefiner-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, UNDEFINER))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)))))))) (IL:\\\,@ (AND PROTOTYPE-FN (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME "prototype-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, PROTOTYPE-FN))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER (IL:\\\, (QUOTE (IL:\\\, TYPE))) (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV))))))))))
+
+(DEFDEFINER (DEFDEFINER-VARIABLE-TYPE (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER-VARIABLE-TYPE (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (INTERN "SEDIT" "SEDIT")) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPES ARG-LIST &BODY BODY) (IL:* IL:|;;| "An extension to the DEFDEFINER universe, this allows the creation of definers that map to multiple file-package types.  The test case, and the only case guaranteed to work, is DEFUN (which now must accept (DEFUN (SETF FOO)...), which needs to be stored as a SETFS file type).") (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINERS NIL) (PROTOTYPE-FNS NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (TYPE-DISCRIMINATOR NIL) (EXPANSION-FNS NIL) (DOCS NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINERS) (SETQ UNDEFINERS (CDR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPES) (SETQ PROTOTYPE-FNS (CDR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:TYPE-DISCRIMINATOR) (SETQ TYPE-DISCRIMINATOR (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (UNLESS TYPE-DISCRIMINATOR (ERROR "DEFDEFINER-VARIABLE-TYPE must have a TYPE-DISCRIMINATOR")) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (DOLIST (TYPE TYPES) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST (LET ((TB (GETF BODY TYPE))) (IF TB (LIST TB) (ERROR "No expansion-function for ~A" TYPE)))) (SETF (GETF EXPANSION-FNS TYPE) EXPANSION-FN) (WHEN DOC (SETQ DOCS (CONCATENATE (QUOTE STRING) DOCS (OR DOCS "
+") (SYMBOL-NAME TYPE) ": " DOC))))) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-"))) (TYPE-DISCRIMINATOR-NAME (GET-DEFINER-NAME NAME "type-discriminator-fn-"))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPES))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (FUNCTION (IL:\\\, TYPE-DISCRIMINATOR))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :TYPE-DISCRIMINATOR)) (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (IL:\\\,@ (AND PROTOTYPE-FNS (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-prototype-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, (GETF PROTOTYPE-FNS TYPE)))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) TYPES))) (IL:\\\,@ (AND DOCS (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCS)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-definition-expander-"))) (EXPANSION-FN (GETF EXPANSION-FNS TYPE))) (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, TYPE))) (QUOTE (IL:\\\, EXPANDER-NAME)))))))) TYPES)) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (IL:\\\,@ (AND UNDEFINERS (MAPCAN (FUNCTION (LAMBDA (TYPE) (WHEN (GETF UNDEFINERS TYPE) (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-undefiner-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, (GETF UNDEFINERS TYPE)))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)) (QUOTE (IL:\\\, TYPE)))))))))) TYPES))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER-VARIABLE-TYPE (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV)))))))))
+
+(DEFUN %EXPAND-DEFINER (DEFINER DEFINITION-WITHOUT-COMMENTS &OPTIONAL ENV) (FUNCALL (GET DEFINER :DEFINITION-EXPANDER) DEFINITION-WITHOUT-COMMENTS ENV))
+
+(DEFUN %DEFINER-NAME (DEFINER DEFINITION-WITHOUT-COMMENTS) (FUNCALL (GET DEFINER :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))
+
+
+
+(IL:* IL:\; "The most commonly-used definers")

+
+
+(DEFDEFINER-VARIABLE-TYPE (DEFUN (:TYPE-DISCRIMINATOR (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) (QUOTE IL:FUNCTIONS)) ((CL::SETF-NAME-P NAME) (QUOTE IL:SETFS)) (T (ERROR "Can't determine type for DEFUN: ~s" NAME)))))) (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) NAME) ((CL::SETF-NAME-P NAME) (CADR NAME)) (T (ERROR "Bad function-name for DEFUN: ~s" NAME)))))) (:PROTOTYPES IL:FUNCTIONS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))) IL:SETFS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (SETF (IL:\\\, NAME)) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))) (:TEMPLATE (:NAME :ARG-LIST :BODY)) (:EDITDATE-OFFSET 3)) (IL:FUNCTIONS IL:SETFS) (NAME ARGS &BODY (BODY DECLS DOCUMENTATION) &ENVIRONMENT ENV) IL:FUNCTIONS (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ BODY))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCUMENTATION)))))))) IL:SETFS (IL:* IL:|;;| "The form is (defun (setf foo) (store-var &rest args) body)") (IL:* IL:|;;| "Strategy is to give the code a name with DEFUN-SETF-NAME.  The name is stored on the :SETF-DEFUN property of the accessor.  This name is there for convenience/documentation only; the name can't be reliably changed by smashing this property (i.e. (SETF (FDEFINITION '(SETF FOO)) #'BAR) essentially does (SETF (SYMBOL-FUNCTION (DEFUN-SETF-NAME 'FOO)) #'BAR); it does NOT change the :SETF-DEFUN property on FOO).") (LET* ((REAL-NAME (SECOND NAME)) (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME))) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, REAL-NAME) (IL:\\\,@ BODY))))) (SET-DEFUN-SETF (QUOTE (IL:\\\, REAL-NAME)) (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, REAL-NAME)) (QUOTE SETF)) (IL:\\\, DOCUMENTATION))))))))))
+
+(DEFDEFINER (DEFINLINE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINLINE (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME ARG-LIST &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is an INTERIM version of DEFINLINE.  Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE.  (It says so right here.)  If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE.  If you do, the compiler will run forever trying to expand the optimizer...  Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.") (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (PARSE-BODY BODY ENV T) (LET ((NEW-LAMBDA (IL:BQUOTE ((IL:\\\, (QUOTE LAMBDA)) (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ CODE)))))) (IL:BQUOTE (PROGN (DEFUN (IL:\\\, NAME) (IL:\\\, ARG-LIST) (IL:\\\,@ BODY)) (DEFOPTIMIZER (IL:\\\, NAME) (IL:\\\, (PACK (LIST "definline-" NAME) (SYMBOL-PACKAGE NAME))) (&REST ARGS) (CONS (QUOTE (IL:\\\, NEW-LAMBDA)) ARGS)))))))
+
+(DEFDEFINER (DEFMACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER (LAMBDA (NAME) (REMPROP NAME (QUOTE IL:ARGNAMES)))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME DEFMACRO-ARGS &BODY DEFMACRO-BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFMACRO: ~S" NAME)) (LET ((CMACRONAME (PACK (LIST "expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC-STRING) (SI::EXPANSION-FUNCTION NAME DEFMACRO-ARGS DEFMACRO-BODY) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, CMACRONAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (MACRO-FUNCTION (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, CMACRONAME))) (IL:\\\,@ (AND DOC-STRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC-STRING)))))) (IL:\\\,@ (WHEN COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:ARGNAMES)) (QUOTE (IL:\\\, (MAPCAR (FUNCTION (LAMBDA (ARG) (IF (MEMBER ARG LAMBDA-LIST-KEYWORDS) ARG (PRIN1-TO-STRING ARG)))) (IL:\\SIMPLIFY.CL.ARGLIST DEFMACRO-ARGS))))))))))))))
+
+(DEFDEFINER (DEFVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFCONSTANT (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFCONSTANT (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (IL:\\\,@ (IF (CONSTANTP NAME) (IL:BQUOTE ((SET-CONSTANTP (QUOTE (IL:\\\, NAME)) NIL))))) (SETQ (IL:\\\, NAME) (IL:\\\, VALUE)) (PROCLAIM (QUOTE (SI::CONSTANT (IL:\\\, NAME)))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFGLOBALVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:* IL:|;;| "Use IL:SETQ here or the INIT dies.") (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFGLOBALPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+
+
+(IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.")

+
+
+(DEF-DEFINE-TYPE IL:SPECIAL-FORMS "Common Lisp special forms" :UNDEFINER %REMOVE-SPECIAL-FORM)
+
+(DEFUN %REMOVE-SPECIAL-FORM (X) (IL:/REMPROP X (QUOTE IL:SPECIAL-FORM)))
+
+(DEFDEFINER (DEFINE-SPECIAL-FORM (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:SPECIAL-FORMS (NAME ARGS &REST BODY) (COND ((NULL BODY) (ASSERT (SYMBOLP NAME) NIL "Ill-formed short DEFINE-SPECIAL-FORM; ~S is not a symbol." ARGS) (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, ARGS))))) (T (LET ((SF (INTERN (CONCATENATE (QUOTE STRING) "interpret-" (STRING NAME)) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOC) (IL:PARSE-DEFMACRO ARGS (QUOTE $$TAIL) BODY NAME NIL :PATH (QUOTE $$TAIL) :ENVIRONMENT (QUOTE $$ENV)) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, SF))) (FUNCTION (LAMBDA ($$TAIL $$ENV) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, SF))))))))))
+
+
+
+(IL:* IL:\; "Form for defining interpreters of special forms")

+
+
+
+
+(IL:* IL:\; "Don't note changes to these properties/variables")

+
+
+(IL:PUTPROPS IL:MACRO-FN IL:PROPTYPE IL:FUNCTIONS)
+
+(IL:PUTPROPS :UNDEFINERS IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:UNDEFINERS IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINER-FOR IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINER-FOR IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINED-BY IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINED-BY IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINITION-NAME IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINITION-NAME IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:\; 
+"Templates for definers not defined here.  These should really be where they're defined.")

+
+
+(IL:PUTPROPS DEFCOMMAND :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY))
+
+(IL:PUTPROPS DEFINE-CONDITION :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE :BODY))
+
+(IL:PUTPROPS DEFINE-MODIFY-MACRO :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST))
+
+(IL:PUTPROPS DEFINE-SETF-METHOD :DEFINITION-PRINT-TEMPLATE (:NAME NIL NIL :BODY))
+
+(IL:PUTPROPS DEFSETF :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :ARG-LIST :BODY))
+
+(IL:PUTPROPS DEFSTRUCT :DEFINITION-PRINT-TEMPLATE (:NAME :BODY))
+
+(IL:PUTPROPS DEFTYPE :DEFINITION-PRINT-TEMPLATE (:NAME NIL :BODY))
+
+
+
+(IL:* IL:|;;| "Arrange for the correct compiler to be used.")

+
+
+(IL:PUTPROPS IL:CMLDEFFER IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLDEFFER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+(IL:PUTPROPS IL:CMLDEFFER IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1900 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLDEFFER.~2~

@@ -0,0 +1,248 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+
(IL:FILECREATED "24-Mar-92 14:56:18" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;3|
 40644  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLDEFFERCOMS)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 15:32:26" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLDEFFER.;2|)
+
+
+; Copyright (c) 1986, 1900, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLDEFFERCOMS)
+
+(IL:RPAQQ IL:CMLDEFFERCOMS ((IL:* IL:|;;;| "DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.") (IL:* IL:|;;| "BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned.") (IL:* IL:|;;;| "Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init") (IL:COMS (IL:* IL:\; "Filepkg interface") (IL:FUNCTIONS REMOVE-COMMENTS PPRINT-DEFINER PPRINT-DEFINER-FITP PPRINT-DEFINER-RECURSE) (IL:VARIABLES IL:*REMOVE-INTERLISP-COMMENTS*) (IL:* IL:\; "Share with xcl?") (IL:FUNCTIONS %DEFINE-TYPE-DELDEF %DEFINE-TYPE-GETDEF %DEFINE-TYPE-FILE-DEFINITIONS %DEFINE-TYPE-FILEGETDEF %DEFINE-TYPE-SAVE-DEFN %DEFINE-TYPE-PUTDEF)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS)) (IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF)) (IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN)) (IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF)) (IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))))) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:P (IL:* IL:|;;| "Set up fake definer prototype stuff for FNS") (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))) (ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))))))))) (IL:COMS (IL:* IL:\; "The groundwork for bootstrapping ") (IL:DEFINE-TYPES IL:DEFINE-TYPES IL:FUNCTIONS IL:VARIABLES) (IL:* IL:\; "DefDefiner itself and friends") (IL:FUNCTIONS SI::EXPANSION-FUNCTION SI::MACRO-FUNCALL WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Compatibility with old cmldeffer") (IL:FUNCTIONS IL:WITHOUT-FILEPKG)) (IL:COMS (IL:* IL:\; "Some special forms") (IL:FUNCTIONS DEFINER DEFINER-VARIABLE-TYPE NAMED-PROGN)) (IL:COMS (IL:* IL:\; "Auxiliary functions") (IL:FUNCTIONS GET-DEFINER-NAME %DELETE-DEFINER) (IL:FUNCTIONS DEF-DEFINE-TYPE DEFDEFINER DEFDEFINER-VARIABLE-TYPE) (IL:FUNCTIONS %EXPAND-DEFINER %DEFINER-NAME)) (IL:COMS (IL:* IL:\; "The most commonly-used definers") (IL:FUNCTIONS DEFUN DEFINLINE DEFMACRO) (IL:FUNCTIONS DEFVAR DEFPARAMETER DEFCONSTANT DEFGLOBALVAR DEFGLOBALPARAMETER)) (IL:COMS (IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.") (IL:DEFINE-TYPES IL:SPECIAL-FORMS) (IL:FUNCTIONS %REMOVE-SPECIAL-FORM) (IL:FUNCTIONS DEFINE-SPECIAL-FORM) (IL:* IL:\; "Form for defining interpreters of special forms")) (IL:COMS (IL:* IL:\; "Don't note changes to these properties/variables") (IL:PROP IL:PROPTYPE IL:MACRO-FN :UNDEFINERS IL:UNDEFINERS :DEFINER-FOR IL:DEFINER-FOR :DEFINED-BY IL:DEFINED-BY :DEFINITION-NAME IL:DEFINITION-NAME) (IL:* IL:\; "Templates for definers not defined here.  These should really be where they're defined.") (IL:PROP :DEFINITION-PRINT-TEMPLATE DEFCOMMAND DEFINE-CONDITION DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD DEFSETF DEFSTRUCT DEFTYPE)) (IL:* IL:|;;| "Arrange for the correct compiler to be used.") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLDEFFER)))
+
+
+
+(IL:* IL:|;;;| 
+"DEF-DEFINE-TYPE and DEFDEFINER -- Your One-Stop Providers of Customized File Manager Facilities.")

+
+
+
+
+(IL:* IL:|;;| 
+"BE VERY CAREFUL CHANGING ANYTHING IN THIS FILE!!!  It is heavily self-referential and thick with bootstrapping problems.  All but the most trivial changes (and some of those) are very tricky to make without blowing yourself out of the water...  You have been warned."
+)

+
+
+
+
+(IL:* IL:|;;;| 
+"Also see the file deffer-runtime for stuff that must be defined before fasl files may be loaded into the init"
+)

+
+
+
+
+(IL:* IL:\; "Filepkg interface")

+
+
+(DEFUN REMOVE-COMMENTS (X) (IL:* IL:|;;;| "Removes SEdit-style comments from the given list structure.") (COND ((NOT (CONSP X)) X) ((AND (CONSP (CAR X)) (EQ (CAAR X) (QUOTE IL:*)) (CONSP (CDAR X)) (OR (MEMBER (CADAR X) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\|)) :TEST (FUNCTION EQ)) (IL:* IL:\; "a sedit comment") (EQ IL:*REMOVE-INTERLISP-COMMENTS* T) (IL:* IL:\; "always strip") (PROGN (IF (EQ IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN)) (WARN "Possible comment not stripped ~S" (CAR X))) NIL))) (REMOVE-COMMENTS (CDR X))) (T (LET ((A (REMOVE-COMMENTS (CAR X))) (D (REMOVE-COMMENTS (CDR X)))) (IF (AND (EQ A (CAR X)) (EQ D (CDR X))) X (CONS A D))))))
+
+(DEFUN PPRINT-DEFINER (DEFINE-EXPRESSION) (DECLARE (SPECIAL IL:FORMFLG IL:SPACEWIDTH)) (IL:* IL:\; "Bound in prettyprinter") (COND ((OR (NULL IL:FORMFLG) (ATOM (CDR DEFINE-EXPRESSION))) (IL:* IL:\; "Degenerate cases or printing as a quoted form--punt to default prettyprinting") DEFINE-EXPRESSION) (T (LET ((IL:TAIL DEFINE-EXPRESSION) (IL:LEFT (IL:DSPXPOSITION)) TEMPLATE TOP-LEVEL-P NEXT TYPE FORM NEWLINEP) (DECLARE (SPECIAL IL:TAIL IL:LEFT)) (IL:* IL:\; "For comment printer") (SETQ TOP-LEVEL-P (EQ IL:LEFT (IL:DSPLEFTMARGIN))) (IL:* IL:\; "Printing definition to file, etc.") (SETQ IL:LEFT (+ IL:LEFT (* 3 IL:SPACEWIDTH))) (IL:* IL:\; "Place we will indent body") (IL:PRIN1 "(") (IL:PRIN2 (CAR IL:TAIL)) (SETQ TEMPLATE (OR (GET (POP IL:TAIL) :DEFINITION-PRINT-TEMPLATE) (QUOTE (:NAME)))) (IL:* IL:|;;| "This code should, and doesn't, pay attention to the NAME function to determine where the name is to decide what should and shouldn't be bold. Right now, it always bolds the second thing. Fortunately, we currently don't have any definers that don't have either the second or CAR of the second as the definition name.") (IL:* IL:|;;| "Also, this code should be careful about calling the NAME function on the form.  Sometimes, the form is not really a call to the definer but instead a back-quoted expression in a macro.  In most such cases, the name is not really there; some comma-quoted expression is there instead.") (IL:WHILE (CONSP IL:TAIL) IL:DO (COND ((AND (LISTP (SETQ NEXT (CAR IL:TAIL))) (EQ (CAR NEXT) IL:COMMENTFLG) (IL:SEMI-COLON-COMMENT-P NEXT)) (IL:* IL:\; "Comments can appear anywhere, so print this one without consuming the template.  ENDLINE has side effect of printing comments") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T)) ((OR (ATOM TEMPLATE) (EQ (SETQ TYPE (POP TEMPLATE)) :BODY)) (IL:* IL:\; "Once we hit the body, there's nothing more special to do.") (RETURN)) (T (IL:SPACES 1) (CASE TYPE (:NAME (IL:* IL:\; "Embolden the name of this thing") (SETQ NEWLINEP NIL) (COND ((NOT TOP-LEVEL-P) (IL:* IL:\; "Nothing special here--could even be a backquoted thing") (PPRINT-DEFINER-RECURSE)) (T (POP IL:TAIL) (COND ((CONSP NEXT) (IL:* IL:\; "Name is a list.  Assume the real name is the car and the rest is an options list or something") (UNLESS (EQ (IL:DSPYPOSITION) (PROGN (IL:PRIN1 "(") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 (CAR NEXT) IL:.FONT IL:DEFAULTFONT) (IL:SPACES 1) (IL:PRINTDEF (CDR NEXT) T T T IL:FNSLST) (IL:PRIN1 ")") (IL:DSPYPOSITION))) (IL:* IL:\; "This thing took more than one line to print, so go to new line") (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*) (SETQ NEWLINEP T))) (T (IL:* IL:\; "Atomic name is bold") (IL:PRINTOUT NIL IL:.FONT IL:LAMBDAFONT IL:.P2 NEXT IL:.FONT IL:DEFAULTFONT)))))) (:ARG-LIST (IL:* IL:\; "NEXT is some sort of argument list.  ") (COND ((NULL NEXT) (IL:* IL:\; "If NIL, be sure to print as ()") (IL:PRIN1 "()") (POP IL:TAIL)) (T (PPRINT-DEFINER-RECURSE))) (SETQ NEWLINEP NIL)) (T (IL:* IL:\; "Just print it, perhaps starting a new line") (UNLESS (OR NEWLINEP (PPRINT-DEFINER-FITP NEXT)) (IL:* IL:\; "Go to new line if getting crowded") (IL:PRINENDLINE IL:LEFT)) (PPRINT-DEFINER-RECURSE) (SETQ NEWLINEP NIL)))))) (IL:* IL:|;;| "We've now gotten to the end of stuff we know how to print.  Just prettyprint the rest") (UNLESS (NULL IL:TAIL) (COND (NEWLINEP (IL:* IL:\; "Already on new line")) ((OR (EQ TYPE :BODY) (NOT (PPRINT-DEFINER-FITP (CAR IL:TAIL)))) (IL:* IL:\; "Go to new line and indent a bit.  Always do this for the part matching &BODY, whether or not the prettyprinter thought that the remainder would \"fit\"") (IL:PRINENDLINE IL:LEFT NIL T)) (T (IL:SPACES 1))) (IL:WHILE (AND (CONSP IL:TAIL) (ATOM (SETQ FORM (CAR IL:TAIL)))) IL:DO (IL:* IL:|;;| "Print this doc string or whatever on its own line.  This is because otherwise the prettyprinter gets confused and tries to put the next thing after the string") (PPRINT-DEFINER-RECURSE) (WHEN (AND (KEYWORDP FORM) (CONSP IL:TAIL)) (IL:* IL:\; "Some sort of keyword-value pair stuff--print it on same line") (IL:SPACES 1) (PPRINT-DEFINER-RECURSE)) (WHEN (NULL IL:TAIL) (RETURN)) (IL:SUBPRINT/ENDLINE IL:LEFT *STANDARD-OUTPUT*)) (IL:PRINTDEF IL:TAIL T T T IL:FNSLST)) (IL:PRIN1 ")") NIL))))
+
+(DEFUN PPRINT-DEFINER-FITP (ITEM) (IL:* IL:|;;| "True if it won't look silly to try to print ITEM at current position instead of starting new line") (IF (CONSP ITEM) (OR (EQ (CAR ITEM) IL:COMMENTFLG) (AND (< (IL:COUNT ITEM) 20) (IL:FITP ITEM))) (< (+ (IL:DSPXPOSITION) (IL:STRINGWIDTH ITEM *STANDARD-OUTPUT*)) (IL:DSPRIGHTMARGIN))))
+
+(DEFUN PPRINT-DEFINER-RECURSE NIL (IL:* IL:|;;| "Print and pop the next element.  Prettyprinter uses the variable IL:TAIL for lookahead") (DECLARE (SPECIAL IL:TAIL)) (IL:SUPERPRINT (CAR IL:TAIL) IL:TAIL NIL *STANDARD-OUTPUT*) (SETQ IL:TAIL (CDR IL:TAIL)))
+
+(DEFVAR IL:*REMOVE-INTERLISP-COMMENTS* (QUOTE :WARN) "Either NIL (don't) T (always do) or :WARN (don't and warn)")
+
+
+
+(IL:* IL:\; "Share with xcl?")

+
+
+(DEFUN %DEFINE-TYPE-DELDEF (NAME TYPE) (IL:* IL:|;;| "DELETE definition of definer-defined NAME as TYPE ") (UNDOABLY-SETF (DOCUMENTATION NAME TYPE) NIL) (LET* ((HT (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HT (GETHASH NAME HT)))) (AND HT (IL:/PUTHASH NAME NIL HT)) (DOLIST (FN (OR (GET TYPE (QUOTE :UNDEFINERS)) (GET TYPE (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) (DOLIST (FN (OR (GET (CAR DEFN) (QUOTE :UNDEFINERS)) (GET (CAR DEFN) (QUOTE IL:UNDEFINERS)))) (FUNCALL FN NAME)) NAME))
+
+(DEFUN %DEFINE-TYPE-GETDEF (NAME TYPE OPTIONS) (IL:* IL:|;;| "GETDEF method for all definers.  The EDIT is so that when you say EDITDEF you get a copy & can know when you made edits.") (LET* ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*)) (DEFN (AND HASH-TABLE (GETHASH NAME HASH-TABLE)))) (IF (TYPECASE OPTIONS (CONS (MEMBER (QUOTE IL:EDIT) OPTIONS :TEST (FUNCTION EQ))) (T (EQ OPTIONS (QUOTE IL:EDIT)))) (COPY-TREE DEFN) DEFN)))
+
+(DEFUN %DEFINE-TYPE-FILE-DEFINITIONS (TYPE NAMES) (IL:* IL:|;;| "get the definitions for NAMES suitable for printing on a file. Like GETDEF but checks.") (MAPCAR (FUNCTION (LAMBDA (NAME) (LET ((DEF (%DEFINE-TYPE-GETDEF NAME TYPE (QUOTE (IL:NOCOPY))))) (IF (NULL DEF) (ERROR (QUOTE IL:NO-SUCH-DEFINITION) :NAME NAME :TYPE TYPE) DEF)))) NAMES))
+
+(DEFUN %DEFINE-TYPE-FILEGETDEF (NAME TYPE SOURCE OPTIONS NOTFOUND) (LET ((VAL (IL:LOADFNS NIL SOURCE (QUOTE IL:GETDEF) (IL:* IL:|;;| "The bletcherous lambda form is require by the interface to loadfns (can't pass a closure)") (IL:BQUOTE (IL:LAMBDA (FIRST SECOND) (AND (MEMBER FIRST (QUOTE (IL:\\\, (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))))) :TEST (FUNCTION EQ)) (LET ((NAMER (OR (GET FIRST (QUOTE :DEFINITION-NAME)) (GET FIRST (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)))) (IF (EQ NAMER (QUOTE SECOND)) (EQUAL SECOND (QUOTE (IL:\\\, NAME))) (EQUAL (FUNCALL NAMER (REMOVE-COMMENTS (IL:READ))) (QUOTE (IL:\\\, NAME))))))))))) (COND ((EQ (CAAR VAL) (QUOTE IL:NOT-FOUND\:)) NOTFOUND) ((CDR VAL) (CONS (QUOTE PROGN) VAL)) (T (CAR VAL)))))
+
+(DEFUN %DEFINE-TYPE-SAVE-DEFN (NAME TYPE DEFINITION) (SETQ TYPE (IL:GETFILEPKGTYPE TYPE (QUOTE TYPE))) (LET ((HASH-TABLE (GETHASH TYPE *DEFINITION-HASH-TABLE*))) (WHEN (NULL HASH-TABLE) (WARN "Couldn't find a hash-table for ~S definitions.~%One will be created." TYPE) (SETQ HASH-TABLE (SETF (GETHASH TYPE *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (FUNCTION EQUAL) :SIZE 50 :REHASH-SIZE 50)))) (LET ((OLD-DEFINITION (GETHASH NAME HASH-TABLE))) (UNLESS (EQUAL DEFINITION OLD-DEFINITION) (WHEN (AND OLD-DEFINITION (NOT (EQ IL:DFNFLG T))) (FORMAT *TERMINAL-IO* "~&New ~A definition for ~S~:[~; (but not installed)~].~%" TYPE NAME (MEMBER IL:DFNFLG (QUOTE (IL:PROP IL:ALLPROP)) :TEST (FUNCTION EQ)))) (IL:/PUTHASH NAME DEFINITION HASH-TABLE) (IL:MARKASCHANGED NAME TYPE (IF OLD-DEFINITION (QUOTE IL:CHANGED) (QUOTE IL:DEFINED)))))))
+
+(DEFUN %DEFINE-TYPE-PUTDEF (NAME TYPE DEFINITION REASON) (IF (NULL DEFINITION) (%DEFINE-TYPE-DELDEF NAME TYPE) (LET ((DEFN-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION))) (UNLESS (AND (CONSP DEFN-WITHOUT-COMMENTS) (MEMBER (CAR DEFN-WITHOUT-COMMENTS) (OR (GET TYPE (QUOTE :DEFINED-BY)) (GET TYPE (QUOTE IL:DEFINED-BY))) :TEST (FUNCTION EQ)) (EQUAL NAME (FUNCALL (OR (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE :DEFINITION-NAME)) (GET (CAR DEFN-WITHOUT-COMMENTS) (QUOTE IL:DEFINITION-NAME)) (QUOTE SECOND)) DEFN-WITHOUT-COMMENTS))) (SIGNAL (QUOTE IL:DEFINER-MISMATCH) :NAME NAME :TYPE TYPE :DEFINITION DEFINITION)) (SETQ DEFINITION (COPY-TREE DEFINITION)) (EVAL (IF IL:LISPXHIST (MAKE-UNDOABLE DEFINITION) DEFINITION)))))
+
+
+
+(IL:* IL:\; "Compatibility with old cmldeffer")

+
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-DELDEF) (QUOTE IL:\\DEFINE-TYPE-DELDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-GETDEF) (QUOTE IL:\\DEFINE-TYPE-GETDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-FILE-DEFINITIONS) (QUOTE IL:\\DEFINE-TYPE-FILE-DEFINITIONS))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-FILEGETDEF) (QUOTE IL:\\DEFINE-TYPE-FILEGETDEF))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-SAVE-DEFN) (QUOTE IL:\\DEFINE-TYPE-SAVE-DEFN))
+
+(IL:MOVD (QUOTE %DEFINE-TYPE-PUTDEF) (QUOTE IL:\\DEFINE-TYPE-PUTDEF))
+
+(IL:MOVD (QUOTE PPRINT-DEFINER) (QUOTE IL:PPRINT-DEFINER))
+)
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:* IL:|;;| "Set up fake definer prototype stuff for FNS")
+
+(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:NLAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:NLAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
+
+(ADD-PROTOTYPE-FN (QUOTE IL:FNS) (QUOTE IL:LAMBDA) (FUNCTION (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (IL:DEFINEQ ((IL:\\\, NAME) (IL:LAMBDA (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))))))
+)
+
+
+
+(IL:* IL:\; "The groundwork for bootstrapping ")

+
+
+(DEF-DEFINE-TYPE IL:DEFINE-TYPES "Definition type")
+
+(DEF-DEFINE-TYPE IL:FUNCTIONS "Common Lisp functions/macros" :UNDEFINER IL:UNDOABLY-FMAKUNBOUND)
+
+(DEF-DEFINE-TYPE IL:VARIABLES "Common Lisp variables" :UNDEFINER UNDOABLY-MAKUNBOUND)
+
+
+
+(IL:* IL:\; "DefDefiner itself and friends")

+
+
+(DEFUN SI::EXPANSION-FUNCTION (NAME ARG-LIST BODY) (IL:* IL:|;;;| "Shared code between DEFMACRO and DEFDEFINER.  Takes the parts of a DEFMACRO and returns two values: a LAMBDA form for the expansion function, and the documentation string found, if any.") (MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (IL:PARSE-DEFMACRO ARG-LIST (QUOTE SI::$$MACRO-FORM) BODY NAME NIL :ENVIRONMENT (QUOTE SI::$$MACRO-ENVIRONMENT)) (VALUES (IL:BQUOTE (LAMBDA (SI::$$MACRO-FORM SI::$$MACRO-ENVIRONMENT) (IL:\\\,@ PARSED-DECLARATIONS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY)))) PARSED-DOCSTRING)))
+
+(DEFMACRO SI::MACRO-FUNCALL (EXPANSION-FUNCTION MACRO-CALL ENV) (IL:* IL:|;;;| "Used by DEFDEFINER as a mechanism for delaying macro-expansion until after checking the value of DFNFLG.  The arguments (unevaluated) are a macro-expansion function and a call on that macro.  The call to MACRO-FUNCALL should expand into the result of expanding the given macro-call.") (FUNCALL EXPANSION-FUNCTION MACRO-CALL ENV))
+
+(DEFMACRO WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (IL:\\\,@ BODY)) (EVAL-WHEN (EVAL) (UNLESS (OR (EQ IL:DFNFLG (QUOTE IL:PROP)) (EQ IL:DFNFLG (QUOTE IL:ALLPROP))) (LET ((IL:FILEPKGFLG NIL) (IL:DFNFLG T)) (IL:\\\,@ BODY)))))))
+
+
+
+(IL:* IL:\; "Compatibility with old cmldeffer")

+
+
+(DEFMACRO IL:WITHOUT-FILEPKG (&BODY BODY) (IL:BQUOTE (WITHOUT-FILEPKG (IL:\\\,@ BODY))))
+
+
+
+(IL:* IL:\; "Some special forms")

+
+
+(DEFMACRO DEFINER (TYPE NAME DEFINITION &OPTIONAL ENV) (LET* ((EXPANDER (GET NAME :DEFINITION-EXPANDER)) (DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
+
+(DEFMACRO DEFINER-VARIABLE-TYPE (NAME DEFINITION &OPTIONAL ENV) (LET* ((DEFINITION-WITHOUT-COMMENTS (REMOVE-COMMENTS DEFINITION)) (TYPE (FUNCALL (GET NAME :TYPE-DISCRIMINATOR) DEFINITION-WITHOUT-COMMENTS)) (EXPANDER (GETF (GET NAME :DEFINITION-EXPANDER) TYPE)) (DEFINITION-NAME (FUNCALL (GET NAME :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))) (IL:BQUOTE (PROGN (WITHOUT-FILEPKG (SI::MACRO-FUNCALL (IL:\\\, EXPANDER) (IL:\\\, DEFINITION-WITHOUT-COMMENTS) (IL:\\\, ENV))) (EVAL-WHEN (EVAL) (UNLESS (NULL IL:FILEPKGFLG) (%DEFINE-TYPE-SAVE-DEFN (QUOTE (IL:\\\, DEFINITION-NAME)) (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, DEFINITION))))) (QUOTE (IL:\\\, DEFINITION-NAME))))))
+
+(DEFMACRO NAMED-PROGN (DEFINER NAME &REST FORMS) (IL:* IL:|;;| "Used by the compiler when processing definers") (IL:BQUOTE (PROGN (IL:\\\,@ FORMS) (QUOTE (IL:\\\, NAME)))))
+
+
+
+(IL:* IL:\; "Auxiliary functions")

+
+
+(DEFUN GET-DEFINER-NAME (DEFINER STRING) (VALUES (INTERN (CONCATENATE (QUOTE STRING) STRING (STRING DEFINER)) (SYMBOL-PACKAGE DEFINER))))
+
+(DEFUN %DELETE-DEFINER (NAME) (AND (SYMBOLP NAME) (LET ((TYPE (OR (GET NAME (QUOTE :DEFINER-FOR)) (GET NAME (QUOTE IL:DEFINER-FOR))))) (IL:/REMPROP NAME (QUOTE :DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE IL:DEFINER-FOR)) (IL:/REMPROP NAME (QUOTE :DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE IL:DEFINITION-NAME)) (IL:/REMPROP NAME (QUOTE :DEFINITION-EXPANDER)) (WHEN TYPE (IF (GET TYPE (QUOTE :DEFINED-BY)) (IL:/PUTPROP TYPE (QUOTE :DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE :DEFINED-BY)))) (IL:/PUTPROP TYPE (QUOTE IL:DEFINED-BY) (REMOVE NAME (GET TYPE (QUOTE IL:DEFINED-BY))))) (IL:* IL:|;;| "need to remove the prototype function!") (LET* ((LOOKUP-TYPE (ASSOC TYPE *DEFINITION-PROTOTYPES* :TEST (FUNCTION EQ)))) (IL:/RPLACD LOOKUP-TYPE (REMOVE NAME (CDR LOOKUP-TYPE) :KEY (FUNCTION CAR))))))))
+
+(DEFDEFINER (DEF-DEFINE-TYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEF-DEFINE-TYPE (IL:\\\, NAME) "Description string")))))) IL:DEFINE-TYPES (NAME DESCRIPTION &KEY UNDEFINER &AUX (CHANGELST (INTERN (CONCATENATE (QUOTE STRING) "CHANGED" (STRING NAME) "LST") (SYMBOL-PACKAGE NAME)))) "Define NAME as a new definition type" (IL:* IL:|;;| "This definition is a clean interface to a hokey implementation.  It works even before the file package is loaded.") (IL:BQUOTE (PROGN (SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE IL:DEFINE-TYPES)) (QUOTE (IL:\\\, DESCRIPTION))) (PUSHNEW (QUOTE ((IL:\\\, NAME) X (IL:P IL:* (%DEFINE-TYPE-FILE-DEFINITIONS (QUOTE (IL:\\\, NAME)) (QUOTE X))))) IL:PRETTYDEFMACROS :TEST (QUOTE EQUAL)) (IL:* IL:|;;| "the information about a type in the file package is split up into a number of different places. PRETTYTYPELST contains a random amount: the changelist is the variable whose top level value contains the list of changed items, and the description is a string used by files? This is duplicated in the CL:DOCUMENTATION mechanism") (PUSHNEW (QUOTE ((IL:\\\, CHANGELST) (IL:\\\, NAME) (IL:\\\, DESCRIPTION))) IL:PRETTYTYPELST :TEST (QUOTE EQUAL)) (DEFGLOBALVAR (IL:\\\, CHANGELST) NIL) (IL:* IL:|;;| "the definition hash table is where the definitions are really stored. Create an entry for this type. Note that definitions are compared using CL:EQUAL so that names can be strings, lists, etc.") (UNLESS (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *DEFINITION-HASH-TABLE*) (MAKE-HASH-TABLE :TEST (QUOTE EQUAL) :SIZE 50 :REHASH-SIZE 50))) (PUSHNEW (QUOTE (IL:\\\, NAME)) IL:FILEPKGTYPES) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:GETDEF)) (QUOTE %DEFINE-TYPE-GETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:DELDEF)) (QUOTE %DEFINE-TYPE-DELDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:PUTDEF)) (QUOTE %DEFINE-TYPE-PUTDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEGETDEF)) (QUOTE %DEFINE-TYPE-FILEGETDEF)) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:FILEPKGCONTENTS)) (QUOTE IL:NILL)) (IL:\\\,@ (WHEN UNDEFINER (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, UNDEFINER)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS))))))))))
+
+(DEFDEFINER (DEFDEFINER (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (QUOTE IL:SEDIT)) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPE ARG-LIST &BODY BODY) (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINER NIL) (PROTOTYPE-FN NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINER) (SETQ UNDEFINER (CADR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPE) (SETQ PROTOTYPE-FN (CADR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST BODY) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME "definition-expander-")) (NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-")))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPE))) (PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (AND UNDEFINER (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME "undefiner-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, UNDEFINER))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)))))))) (IL:\\\,@ (AND PROTOTYPE-FN (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME "prototype-fn-"))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, PROTOTYPE-FN))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER (IL:\\\, (QUOTE (IL:\\\, TYPE))) (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV))))))))))
+
+(DEFDEFINER (DEFDEFINER-VARIABLE-TYPE (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (IF (CONSP NAME) (CAR NAME) NAME)))) (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFDEFINER-VARIABLE-TYPE (IL:\\\, NAME) (IL:\\\, (IF (EQ (IL:EDITMODE) (INTERN "SEDIT" "SEDIT")) (SYMBOL-VALUE (INTERN "BASIC-GAP" "SEDIT")) "Type")) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER %DELETE-DEFINER) (:TEMPLATE (:NAME :TYPE :ARG-LIST :BODY))) IL:FUNCTIONS (NAME TYPES ARG-LIST &BODY BODY) (IL:* IL:|;;| "An extension to the DEFDEFINER universe, this allows the creation of definers that map to multiple file-package types.  The test case, and the only case guaranteed to work, is DEFUN (which now must accept (DEFUN (SETF FOO)...), which needs to be stored as a SETFS file type).") (LET* ((OPTIONS (COND ((CONSP NAME) (PROG1 (CDR NAME) (SETQ NAME (CAR NAME)))) (T NIL))) (NAME-FN NIL) (UNDEFINERS NIL) (PROTOTYPE-FNS NIL) (TEMPLATE NIL) (PRETTYMACRO NIL) (TYPE-DISCRIMINATOR NIL) (EXPANSION-FNS NIL) (DOCS NIL) (EDITDATE-OFFSET NIL)) (DOLIST (OPT-LIST OPTIONS) (CASE (CAR OPT-LIST) ((:UNDEFINERS) (SETQ UNDEFINERS (CDR OPT-LIST))) ((:NAME) (SETQ NAME-FN (CADR OPT-LIST))) ((:PROTOTYPES) (SETQ PROTOTYPE-FNS (CDR OPT-LIST))) ((:TEMPLATE) (SETQ TEMPLATE (CADR OPT-LIST))) ((:PRETTYPRINTMACRO) (SETQ PRETTYMACRO (CADR OPT-LIST))) ((:TYPE-DISCRIMINATOR) (SETQ TYPE-DISCRIMINATOR (CADR OPT-LIST))) ((:EDITDATE-OFFSET) (SETQ EDITDATE-OFFSET (CADR OPT-LIST))) (OTHERWISE (CERROR "Ignore the option" "Unrecognized option to DefDefiner: ~S" OPT-LIST)))) (UNLESS TYPE-DISCRIMINATOR (ERROR "DEFDEFINER-VARIABLE-TYPE must have a TYPE-DISCRIMINATOR")) (IL:* IL:|;;| "Crap out now if junk in EDITDATE-OFFSET") (WHEN (AND EDITDATE-OFFSET (NOT (INTEGERP EDITDATE-OFFSET))) (ERROR ":EDITDATE-OFFSET must be an integer, not ~a" EDITDATE-OFFSET)) (DOLIST (TYPE TYPES) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC) (SI::EXPANSION-FUNCTION NAME ARG-LIST (LET ((TB (GETF BODY TYPE))) (IF TB (LIST TB) (ERROR "No expansion-function for ~A" TYPE)))) (SETF (GETF EXPANSION-FNS TYPE) EXPANSION-FN) (WHEN DOC (SETQ DOCS (CONCATENATE (QUOTE STRING) DOCS (OR DOCS "
+") (SYMBOL-NAME TYPE) ": " DOC))))) (UNLESS (OR TEMPLATE PRETTYMACRO (NOT (MEMBER (QUOTE &BODY) ARG-LIST))) (IL:* IL:\; "Tell default prettyprinter where the body is") (SETQ TEMPLATE (NCONC (IL:FOR X IL:IN ARG-LIST IL:UNTIL (EQ X (QUOTE &BODY)) IL:UNLESS (MEMBER X LAMBDA-LIST-KEYWORDS) IL:COLLECT NIL) (LIST :BODY))) (WHEN (AND (NULL (CAR TEMPLATE)) (NULL NAME-FN)) (IL:* IL:\; "Name is in default place") (SETF (CAR TEMPLATE) :NAME))) (LET ((NAME-FN-NAME (IF (CONSP NAME-FN) (GET-DEFINER-NAME NAME "name-fn-"))) (TYPE-DISCRIMINATOR-NAME (GET-DEFINER-NAME NAME "type-discriminator-fn-"))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD EVAL ) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINER-FOR)) (QUOTE (IL:\\\, TYPES))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (FUNCTION (IL:\\\, TYPE-DISCRIMINATOR))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :TYPE-DISCRIMINATOR)) (QUOTE (IL:\\\, TYPE-DISCRIMINATOR-NAME))) (IL:\\\,@ (AND PROTOTYPE-FNS (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((PROTOTYPE-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-prototype-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, PROTOTYPE-FN-NAME))) (FUNCTION (IL:\\\, (GETF PROTOTYPE-FNS TYPE)))) (ADD-PROTOTYPE-FN (QUOTE (IL:\\\, TYPE)) (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, PROTOTYPE-FN-NAME)))))))) TYPES))) (IL:\\\,@ (AND DOCS (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCS)))))) (IL:\\\,@ (AND TEMPLATE (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-PRINT-TEMPLATE)) (QUOTE (IL:\\\, TEMPLATE))))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-NAME)) (QUOTE (IL:\\\, (OR NAME-FN-NAME NAME-FN (QUOTE SECOND))))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (TYPE) (LET ((EXPANDER-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-definition-expander-"))) (EXPANSION-FN (GETF EXPANSION-FNS TYPE))) (IL:BQUOTE ((PUSHNEW (QUOTE (IL:\\\, NAME)) (GET (QUOTE (IL:\\\, TYPE)) (QUOTE :DEFINED-BY))) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :DEFINITION-EXPANDER)) (QUOTE (IL:\\\, TYPE))) (QUOTE (IL:\\\, EXPANDER-NAME)))))))) TYPES)) (IL:\\\,@ (IF NAME-FN-NAME (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME-FN-NAME))) (FUNCTION (IL:\\\, NAME-FN))))))) (IL:\\\,@ (AND UNDEFINERS (MAPCAN (FUNCTION (LAMBDA (TYPE) (WHEN (GETF UNDEFINERS TYPE) (LET ((UNDEFINER-FN-NAME (GET-DEFINER-NAME NAME (CONCATENATE (QUOTE STRING) (SYMBOL-NAME TYPE) "-undefiner-fn-")))) (IL:BQUOTE ((SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, UNDEFINER-FN-NAME))) (FUNCTION (IL:\\\, (GETF UNDEFINERS TYPE)))) (PUSHNEW (QUOTE (IL:\\\, UNDEFINER-FN-NAME)) (GETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE :UNDEFINERS)) (QUOTE (IL:\\\, TYPE)))))))))) TYPES))) (IL:\\\,@ (AND EDITDATE-OFFSET (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) :EDITDATE-OFFSET) (IL:\\\, EDITDATE-OFFSET)))))) (PUSHNEW (QUOTE ((IL:\\\, NAME) (IL:\\\,@ (OR PRETTYMACRO (QUOTE PPRINT-DEFINER))))) IL:PRETTYPRINTMACROS :TEST (QUOTE EQUAL))) (DEFMACRO (IL:\\\, NAME) (&WHOLE DEFINITION &ENVIRONMENT ENV) (IL:BQUOTE (DEFINER-VARIABLE-TYPE (IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\, DEFINITION) (IL:\\\, ENV)))))))))
+
+(DEFUN %EXPAND-DEFINER (DEFINER DEFINITION-WITHOUT-COMMENTS &OPTIONAL ENV) (FUNCALL (GET DEFINER :DEFINITION-EXPANDER) DEFINITION-WITHOUT-COMMENTS ENV))
+
+(DEFUN %DEFINER-NAME (DEFINER DEFINITION-WITHOUT-COMMENTS) (FUNCALL (GET DEFINER :DEFINITION-NAME) DEFINITION-WITHOUT-COMMENTS))
+
+
+
+(IL:* IL:\; "The most commonly-used definers")

+
+
+(DEFDEFINER-VARIABLE-TYPE (DEFUN (:TYPE-DISCRIMINATOR (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) (QUOTE IL:FUNCTIONS)) ((CL::SETF-NAME-P NAME) (QUOTE IL:SETFS)) (T (ERROR "Can't determine type for DEFUN: ~s" NAME)))))) (:NAME (LAMBDA (WHOLE) (LET ((NAME (SECOND WHOLE))) (COND ((SYMBOLP NAME) NAME) ((CL::SETF-NAME-P NAME) (CADR NAME)) (T (ERROR "Bad function-name for DEFUN: ~s" NAME)))))) (:PROTOTYPES IL:FUNCTIONS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))) IL:SETFS (LAMBDA (NAME) (IL:BQUOTE (DEFUN (SETF (IL:\\\, NAME)) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE)))))) (:TEMPLATE (:NAME :ARG-LIST :BODY)) (:EDITDATE-OFFSET 3)) (IL:FUNCTIONS IL:SETFS) (NAME ARGS &BODY (BODY DECLS DOCUMENTATION) &ENVIRONMENT ENV) IL:FUNCTIONS (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ BODY))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOCUMENTATION)))))))) IL:SETFS (IL:* IL:|;;| "The form is (defun (setf foo) (store-var &rest args) body)") (IL:* IL:|;;| "Strategy is to give the code a name with DEFUN-SETF-NAME.  The name is stored on the :SETF-DEFUN property of the accessor.  This name is there for convenience/documentation only; the name can't be reliably changed by smashing this property (i.e. (SETF (FDEFINITION '(SETF FOO)) #'BAR) essentially does (SETF (SYMBOL-FUNCTION (DEFUN-SETF-NAME 'FOO)) #'BAR); it does NOT change the :SETF-DEFUN property on FOO).") (LET* ((REAL-NAME (SECOND NAME)) (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME))) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (FUNCTION (LAMBDA (IL:\\\, ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, REAL-NAME) (IL:\\\,@ BODY))))) (SET-DEFUN-SETF (QUOTE (IL:\\\, REAL-NAME)) (QUOTE (IL:\\\, DEFUN-SETF-NAME))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, REAL-NAME)) (QUOTE SETF)) (IL:\\\, DOCUMENTATION))))))))))
+
+(DEFDEFINER (DEFINLINE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINLINE (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME ARG-LIST &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "This is an INTERIM version of DEFINLINE.  Eventually, this will just turn into a DEFUN and a PROCLAIM INLINE.  (It says so right here.)  If you're using this one, DO NOT make any recursive calls in the body of the DEFINLINE.  If you do, the compiler will run forever trying to expand the optimizer...  Once the INLINE version gets working (in the PavCompiler only) that restriction will be lifted.") (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (PARSE-BODY BODY ENV T) (LET ((NEW-LAMBDA (IL:BQUOTE ((IL:\\\, (QUOTE LAMBDA)) (IL:\\\, ARG-LIST) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\,@ CODE)))))) (IL:BQUOTE (PROGN (DEFUN (IL:\\\, NAME) (IL:\\\, ARG-LIST) (IL:\\\,@ BODY)) (DEFOPTIMIZER (IL:\\\, NAME) (IL:\\\, (PACK (LIST "definline-" NAME) (SYMBOL-PACKAGE NAME))) (&REST ARGS) (CONS (QUOTE (IL:\\\, NEW-LAMBDA)) ARGS)))))))
+
+(DEFDEFINER (DEFMACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\,@ (%MAKE-FUNCTION-PROTOTYPE))))))) (:UNDEFINER (LAMBDA (NAME) (REMPROP NAME (QUOTE IL:ARGNAMES)))) (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:FUNCTIONS (NAME DEFMACRO-ARGS &BODY DEFMACRO-BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFMACRO: ~S" NAME)) (LET ((CMACRONAME (PACK (LIST "expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (EXPANSION-FN DOC-STRING) (SI::EXPANSION-FUNCTION NAME DEFMACRO-ARGS DEFMACRO-BODY) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, CMACRONAME))) (FUNCTION (IL:\\\, EXPANSION-FN))) (SETF (MACRO-FUNCTION (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, CMACRONAME))) (IL:\\\,@ (AND DOC-STRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE FUNCTION)) (IL:\\\, DOC-STRING)))))) (IL:\\\,@ (WHEN COMPILER::*NEW-COMPILER-IS-EXPANDING* (IL:BQUOTE ((SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:ARGNAMES)) (QUOTE (IL:\\\, (MAPCAR (FUNCTION (LAMBDA (ARG) (IF (MEMBER ARG LAMBDA-LIST-KEYWORDS) ARG (PRIN1-TO-STRING ARG)))) (IL:\\SIMPLIFY.CL.ARGLIST DEFMACRO-ARGS))))))))))))))
+
+(DEFDEFINER (DEFVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (SPECIAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFCONSTANT (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFCONSTANT (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (IL:\\\,@ (IF (CONSTANTP NAME) (IL:BQUOTE ((SET-CONSTANTP (QUOTE (IL:\\\, NAME)) NIL))))) (SETQ (IL:\\\, NAME) (IL:\\\, VALUE)) (PROCLAIM (QUOTE (SI::CONSTANT (IL:\\\, NAME)))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFGLOBALVAR (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALVAR (IL:\\\, NAME))))))) IL:VARIABLES (NAME &OPTIONAL (INITIAL-VALUE NIL IVP) DOCUMENTATION) (IL:* IL:|;;| "Use IL:SETQ here or the INIT dies.") (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (IL:\\\,@ (AND IVP (IL:BQUOTE ((OR (BOUNDP (QUOTE (IL:\\\, NAME))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE))))))) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+(DEFDEFINER (DEFGLOBALPARAMETER (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFGLOBALPARAMETER (IL:\\\, NAME) "Value" "Documentation string")))))) IL:VARIABLES (NAME INITIAL-VALUE &OPTIONAL DOCUMENTATION) (IL:BQUOTE (PROGN (PROCLAIM (QUOTE (GLOBAL (IL:\\\, NAME)))) (SETQ (IL:\\\, NAME) (IL:\\\, INITIAL-VALUE)) (IL:\\\,@ (AND DOCUMENTATION (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE VARIABLE)) (IL:\\\, DOCUMENTATION)))))))))
+
+
+
+(IL:* IL:\; "Here so that the evaluator can be in the init without definers being in the init.")

+
+
+(DEF-DEFINE-TYPE IL:SPECIAL-FORMS "Common Lisp special forms" :UNDEFINER %REMOVE-SPECIAL-FORM)
+
+(DEFUN %REMOVE-SPECIAL-FORM (X) (IL:/REMPROP X (QUOTE IL:SPECIAL-FORM)))
+
+(DEFDEFINER (DEFINE-SPECIAL-FORM (:TEMPLATE (:NAME :ARG-LIST :BODY))) IL:SPECIAL-FORMS (NAME ARGS &REST BODY) (COND ((NULL BODY) (ASSERT (SYMBOLP NAME) NIL "Ill-formed short DEFINE-SPECIAL-FORM; ~S is not a symbol." ARGS) (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, ARGS))))) (T (LET ((SF (INTERN (CONCATENATE (QUOTE STRING) "interpret-" (STRING NAME)) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOC) (IL:PARSE-DEFMACRO ARGS (QUOTE $$TAIL) BODY NAME NIL :PATH (QUOTE $$TAIL) :ENVIRONMENT (QUOTE $$ENV)) (IL:BQUOTE (PROGN (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, SF))) (FUNCTION (LAMBDA ($$TAIL $$ENV) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (GET (QUOTE (IL:\\\, NAME)) (QUOTE IL:SPECIAL-FORM)) (QUOTE (IL:\\\, SF))))))))))
+
+
+
+(IL:* IL:\; "Form for defining interpreters of special forms")

+
+
+
+
+(IL:* IL:\; "Don't note changes to these properties/variables")

+
+
+(IL:PUTPROPS IL:MACRO-FN IL:PROPTYPE IL:FUNCTIONS)
+
+(IL:PUTPROPS :UNDEFINERS IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:UNDEFINERS IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINER-FOR IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINER-FOR IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINED-BY IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINED-BY IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :DEFINITION-NAME IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:DEFINITION-NAME IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:\; 
+"Templates for definers not defined here.  These should really be where they're defined.")

+
+
+(IL:PUTPROPS DEFCOMMAND :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :BODY))
+
+(IL:PUTPROPS DEFINE-CONDITION :DEFINITION-PRINT-TEMPLATE (:NAME :VALUE :BODY))
+
+(IL:PUTPROPS DEFINE-MODIFY-MACRO :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST))
+
+(IL:PUTPROPS DEFINE-SETF-METHOD :DEFINITION-PRINT-TEMPLATE (:NAME NIL NIL :BODY))
+
+(IL:PUTPROPS DEFSETF :DEFINITION-PRINT-TEMPLATE (:NAME :ARG-LIST :ARG-LIST :BODY))
+
+(IL:PUTPROPS DEFSTRUCT :DEFINITION-PRINT-TEMPLATE (:NAME :BODY))
+
+(IL:PUTPROPS DEFTYPE :DEFINITION-PRINT-TEMPLATE (:NAME NIL :BODY))
+
+
+
+(IL:* IL:|;;| "Arrange for the correct compiler to be used.")

+
+
+(IL:PUTPROPS IL:CMLDEFFER IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLDEFFER IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "XCL"))
+(IL:PUTPROPS IL:CMLDEFFER IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1900 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLDOC

@@ -0,0 +1,81 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 10:41:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLDOC.;2"
 3493   
+
+      previous date%: "14-Apr-92 20:18:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLDOC.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLDOCCOMS)
+
+(RPAQQ CMLDOCCOMS
 (
+
+(* ;;; "Documentation strings")

+
+                       (VARIABLES *DOCUMENTATION-HASH-TABLE*)
+                       (FUNCTIONS LISP:DOCUMENTATION HASH-TABLE-FOR-DOC-TYPE SET-DOCUMENTATION)
+                       (SETFS LISP:DOCUMENTATION)
+                       
+                       (* ;; "Use the proper compiler")

+
+                       (PROP FILETYPE CMLDOC)))
+
+
+
+(* ;;; "Documentation strings")

+
+
+(DEFGLOBALVAR *DOCUMENTATION-HASH-TABLE*

+
+(* ;;; "This is the repository for all documentation strings in the system.  It is a two-level hash-table scheme, just like *definition-hash-table*.  At the first level, *DOCUMENTATION-HASH-TABLE* maps the symbols that name documentation-types into a separate hash table for each type.  Those tables map names into the documentation strings for those names.  The first-level table uses an EQ test while the second-level ones use CL:EQUAL.")

+
+   (* ;; "The hash-table is initialized to have second-level tables for each of the required documentation types.")

+
+   (LET ((LISP::HT (LISP:MAKE-HASH-TABLE :TEST 'EQ :SIZE 10 :REHASH-SIZE 5)))
+        [FOR
 TYPE-LIST IN
 '((TYPES TYPE)
+                                    (SETFS LISP:SETF)
+                                    (STRUCTURES LISP:STRUCTURE RECORD RECORDS)
+                                    (FUNCTIONS LISP:FUNCTION FN FNS)
+                                    (VARIABLES LISP:VARIABLE VAR VARS))
+           DO
 (LET ((TABLE (LISP:MAKE-HASH-TABLE :TEST 'LISP:EQUAL :SIZE 50 :REHASH-SIZE 50)))
+                       (FOR
 TYPE IN
 TYPE-LIST DO
 (LISP:SETF (LISP:GETHASH TYPE LISP::HT)
+                                                                    TABLE]
+        LISP::HT))
+
+(LISP:DEFUN LISP:DOCUMENTATION
 (NAME DOC-TYPE)
+   (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE
 DOC-TYPE)))
+
+(LISP:DEFUN HASH-TABLE-FOR-DOC-TYPE
 (DOC-TYPE)
+   (OR (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*)
+       (AND FILEPKGFLG (GETHASH (SETQ DOC-TYPE (GETFILEPKGTYPE DOC-TYPE 'TYPE))
+
+                              (* ;; 
+
                  "note that GETFILEPKGTYPE will signal an error if it doesn't recognize the type.")

+
+                              *DOCUMENTATION-HASH-TABLE*))
+       (LISP:SETF (GETHASH DOC-TYPE *DOCUMENTATION-HASH-TABLE*)
+              (LISP:MAKE-HASH-TABLE :TEST 'LISP:EQUAL :SIZE 50 :REHASH-SIZE 50))))
+
+(LISP:DEFUN SET-DOCUMENTATION
 (NAME DOC-TYPE NEW-STRING) (* ; "Edited 14-Apr-92 20:16 by jrb:")

+   (LISP:CHECK-TYPE NEW-STRING (OR (EQL NIL)
+                                   STRING))
+   (LISP:IF LISPXHIST
+       (UNDOABLY-SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE
 DOC-TYPE))
+              NEW-STRING)
+       (LISP:SETF (GETHASH NAME (HASH-TABLE-FOR-DOC-TYPE
 DOC-TYPE))
+              NEW-STRING)))
+
+(LISP:DEFSETF LISP:DOCUMENTATION
 SET-DOCUMENTATION)
+
+
+
+(* ;; "Use the proper compiler")

+
+
+(PUTPROPS CMLDOC
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLDOC COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLEXEC

@@ -0,0 +1,821 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED " 8-Apr-92 22:06:20" {DSK}<usr>local>lde>lispcore>sources>CMLEXEC.;2
 70091  
+
+      changes to%:  (ALISTS (BackgroundMenuCommands EXEC))
+
+      previous date%: "25-Jun-91 12:22:29" {DSK}<usr>local>lde>lispcore>sources>CMLEXEC.;1)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLEXECCOMS)
+
+(RPAQQ CMLEXECCOMS ((FILES CMLUNDO PROFILE) (XCL:PROFILES "EXEC") (STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY) (* ; "These are public except for command-entry.") (FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE XCL:SET-DEFAULT-EXEC-TYPE XCL::ENTER-EXEC-FUNCTION) (SETFS XCL::GET-PROCESS-PROFILE) (FUNCTIONS DO-EVENT EXEC EXEC-EVAL PRINT-ALL-DOCUMENTATION PRINT-DOCUMENTATION VALUE-OF ADD-EXEC EXEC-READ-LINE EXEC-EVENT-ID-PROMPT FIND-EXEC-COMMAND) (FUNCTIONS CIRCLAR-COPYER) (FNS COPY-CIRCLE) (* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (FNS EXEC-READ DIR) (VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:/// *CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED* *THIS-EXEC-COMMANDS* *EXEC-COMMAND-TABLE* *DEBUGGER-COMMAND-TABLE* *CURRENT-EXEC-TYPE* *EXEC-MAKE-UNDOABLE-P*) (VARIABLES *EDIT-INPUT-WITH-TTYIN*) (FNS DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EVENTS-INPUT EXEC-PRIN1 EXEC-VALUE-OF GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT LISPXREPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE READ) (QUOTE TTYINREAD)) (MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT)) (SETQ BackgroundMenu))) (FUNCTIONS CASE-EQUALP EXEC-EVENT-PROPS EXEC-PRINT EXEC-FORMAT) (ALISTS (BackgroundMenuCommands EXEC)) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (* ;; "Exec Commands") (DEFINE-TYPES COMMANDS) (FUNCTIONS DEFCOMMAND) (COMMANDS "?" "??" "CONN" "DA" "DIR" "DO-EVENTS" "FIX" "FORGET" "NAME" "NDIR" "PL" "REDO" "REMEMBER" "SHH" "UNDO" "USE" "PP") (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLEXEC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA DIR) (NLAML) (LAMA)))))
+
+(FILESLOAD CMLUNDO PROFILE)
+
+(XCL:DEFPROFILE "EXEC" (XCL:*DEBUGGER-PROMPT* "") (XCL:*EXEC-PROMPT* "") (*READTABLE* "XCL") (*PACKAGE* "XCL") (XCL:*EVAL-FUNCTION* (QUOTE CL:EVAL)))
+
+(CL:DEFSTRUCT (COMMAND-ENTRY (:TYPE LIST)) ARGUMENTS FUNCTION MODE)
+
+(CL:DEFSTRUCT (EXEC-EVENT-ID (:TYPE LIST)) NUMBER NAME dummy)
+
+(CL:DEFSTRUCT (EXEC-EVENT (:TYPE LIST)) INPUT ID (VALUE *NOT-YET-EVALUATED*) dummy)
+
+(CL:DEFSTRUCT (HISTORY (:TYPE LIST)) (EVENTS NIL) (INDEX 0) (SIZE 100) (MOD 100))
+
+
+
+(* ; "These are public except for command-entry.")

+
+
+(CL:DEFUN XCL::EXEC-CLOSEFN (XCL::WINDOW) (LET ((XCL::PROCESS (WINDOWPROP XCL::WINDOW (QUOTE PROCESS)))) (COND ((EQ (THIS.PROCESS) XCL::PROCESS) (ADD.PROCESS (BQUOTE (CLOSEW (QUOTE (\, XCL::WINDOW))))) (QUOTE DON'T)) ((PROCESSP XCL::PROCESS) (CL:IF (TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T)) (DEL.PROCESS XCL::PROCESS)))))
+
+(CL:DEFUN XCL::EXEC-SHRINKFN (XCL::WINDOW) (LET ((XCL::PROCESS (WINDOWPROP XCL::WINDOW (QUOTE PROCESS)))) (COND ((EQ (THIS.PROCESS) XCL::PROCESS) (ADD.PROCESS (BQUOTE (SHRINKW (QUOTE (\, XCL::WINDOW))))) (QUOTE DON'T)) ((TTY.PROCESSP XCL::PROCESS) (TTY.PROCESS T) NIL))))
+
+(CL:DEFUN XCL::SETUP-EXEC-WINDOW (XCL::WINDOW) "Add (non-title) properties to a new exec window." (WINDOWADDPROP XCL::WINDOW (QUOTE CLOSEFN) (QUOTE XCL::EXEC-CLOSEFN)) (WINDOWADDPROP XCL::WINDOW (QUOTE SHRINKFN) (QUOTE XCL::EXEC-SHRINKFN)) XCL::WINDOW)
+
+(CL:DEFUN XCL::EXEC-TITLE-FUNCTION (XCL::WINDOW EXEC-ID) (WINDOWPROP XCL::WINDOW (QUOTE TITLE) (CL:FORMAT NIL "Exec ~A (~A)" EXEC-ID (READTABLEPROP *READTABLE* (QUOTE NAME)))))
+
+(CL:DEFUN FIX-FORM (INPUT &OPTIONAL (CIRCLE-FLAG NIL)) (* ;;; "Edits a form, in the current window if it is shorter than ttyinfixlimit, or if longer in the display editor using edite.  Returns the newly edited form.") (* ; "Edited by Tomoru Teruuchi") (COND ((OR (NOT *EDIT-INPUT-WITH-TTYIN*) (NOT (IMAGESTREAMP (TTYDISPLAYSTREAM))) (AND (NOT CIRCLE-FLAG) (EQUAL 0 (COUNTDOWN INPUT TTYINFIXLIMIT))) (* ; "(IGEQ (COUNT INPUT) TTYINFIXLIMIT)  is Original Code. But This Codecan't accept circler. Edited by TT (31-May-1990)")) (EDITE (CL:IF (AND (EQ 1 (LENGTH INPUT)) (CL:CONSP (CAR INPUT))) (CAR INPUT) INPUT) NIL NIL T NIL :CLOSE-ON-COMPLETION) INPUT) (T (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (CURSOR T) (* ; "make sure can edit (in case cursor smashed somehow?)") (CL:WHEN NIL (* ; "Old expression") (TTYIN "" NIL NIL (QUOTE LISPXREAD) NIL NIL BUFFER-EXPR-FROM-BELOW *READTABLE*)) (EXEC-READ-LINE (LET ((%#RPARS NIL) (FONTCHANGEFLG NIL) (*PRINT-ESCAPE* T) (*PRINT-RADIX* (NOT (= *READ-BASE* 10))) (*PRINT-BASE* *READ-BASE*) (*PRINT-LEVEL* NIL) (*PRINT-LENGTH* NIL) (*PRINT-GENSYM* (QUOTE :REREAD)) (*PRINT-ARRAY* T) (*PRINT-STRUCTURE* T)) (DECLARE (CL:SPECIAL %#RPARS FONTCHANGEFLG) (* ; "others are already globally special ")) (CL:WITH-OUTPUT-TO-STRING (STR) (FOR X ON INPUT DO (IF CIRCLE-FLAG THEN (* ; "Edited by TT (31-May-1990) CL:PRIN1 can print circlar") (CL:PRIN1 (CAR X) STR) ELSEIF (LISTP (CAR X)) THEN (PRINTDEF (CAR X) (POSITION STR) NIL NIL NIL STR) ELSE (PRIN2 (CAR X) STR)) (AND (CDR X) (PRIN1 " " STR)))))))))
+
+(CL:DEFUN XCL::GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS))) (PROCESSPROP XCL::PROCESS (QUOTE PROFILE)))
+
+(CL:DEFUN XCL::SAVE-CURRENT-EXEC-PROFILE NIL "Resave the profiled bindings of the exec process into their cache." (LET ((XCL::PROFILE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)))) (CL:IF (XCL:PROFILE-P XCL::PROFILE) (XCL:SAVE-PROFILE XCL::PROFILE))))
+
+(CL:DEFUN XCL::SETF-GET-PROCESS-PROFILE (&OPTIONAL (XCL::PROCESS (THIS.PROCESS)) (XCL::PROFILE XCL:*PROFILE*)) (CL:SETQ XCL::PROFILE (XCL::PROFILIZE XCL::PROFILE)) (PROCESSPROP XCL::PROCESS (QUOTE PROFILE) XCL::PROFILE) XCL::PROFILE)
+
+(CL:DEFUN XCL:SET-EXEC-TYPE (TYPE) "Set the current Exec's type to TYPE" (* ;; "The EXECA-FRAME bit is a gross hack to make this function work inside init files.  The problem is that you want to affect the EXEC, regardless of who has bound the per-exec variables between here an the EXEC frame.  Yech.") (LET ((XCL::EXECA-FRAME (STKPOS (QUOTE XCL::EXECA0001)))) (COND (XCL::EXECA-FRAME (ENVEVAL (BQUOTE (XCL:RESTORE-PROFILE (QUOTE (\, TYPE)))) XCL::EXECA-FRAME XCL::EXECA-FRAME)) (T (XCL:RESTORE-PROFILE TYPE)))))
+
+(CL:DEFUN XCL:SET-DEFAULT-EXEC-TYPE (TYPE) (SETTOPVAL (QUOTE XCL:*PROFILE*) TYPE))
+
+(CL:DEFUN XCL::ENTER-EXEC-FUNCTION (XCL::EXEC-FUNCTION XCL::PROFILE XCL::ID) "Start up an exec function in the proper profile, setting the default window title properly." (XCL:WITH-PROFILE (XCL:COPY-PROFILE XCL::PROFILE) (XCL::EXEC-TITLE-FUNCTION T (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (CL:FUNCALL XCL::EXEC-FUNCTION)))
+
+(CL:DEFSETF XCL::GET-PROCESS-PROFILE XCL::SETF-GET-PROCESS-PROFILE)
+
+(CL:DEFUN DO-EVENT (ORIGINAL-INPUT ENVIRONMENT &OPTIONAL (FUNCTION (FUNCTION EVAL-INPUT))) (* ; "Edited by Tomoru Teruuchi") (PROG (TODO INPUT VALUES COM (ADD-TO-SPELLING-LIST ADDSPELLFLG) STR (RETRYFLAG NIL) (* ; "A really gross hack for RETRY to always break.  It exists because: users can setq HELPFLAG anywhere (can't bind it in DO-EVENTand set it in RETRY), RETRY operates on commands (can't wrap the form with a binding of HELPFLAG).")) (DECLARE (CL:SPECIAL RETRYFLAG)) (* ; "RETRY command sets this variable if it wants to be sure to break.") (DSPFONT PRINTOUTFONT T) (SETQ INPUT ORIGINAL-INPUT) RETRY (SETQ TODO (COPY-CIRCLE INPUT)) (* ; "Break EQ link between input and evaluated form (todo), so that in-place mods don't affect history.") (COND ((AND (OR (STRINGP (CAR INPUT)) (CL:SYMBOLP (CAR INPUT))) (PROGN (SETQ STR (STRING (CAR INPUT))) (SOME *THIS-EXEC-COMMANDS* (FUNCTION (LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE))))))) (* ;; "Handle exec commands.") (CL:ECASE (COMMAND-ENTRY-MODE COM) (:QUIET (MAPC (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT))) (FUNCTION (LAMBDA (X) (EXEC-PRINT X)))) (SETQ IT (CAR VALUES)) (* ; "just do it and return") (RETURN)) ((:HISTORY :INPUT) (* ; " create new input. If an error occurs while handling the command, the INPUT will be left as the original input.") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (SETQ INPUT (CL:FUNCALL (COMMAND-ENTRY-FUNCTION COM) INPUT ENVIRONMENT)) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT) (* ; " Overwrite the original input with the newly generated one.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE *HISTORY*) ORIGINAL-INPUT (EXEC-EVENT-PROPS *CURRENT-EVENT*)))) (GO RETRY) (* ; " could have generated a command")) ((NIL :EVAL) (* ; " normal kind of command, just apply") (SETQ TODO (BQUOTE ((CL:FUNCALL (QUOTE (\, (COMMAND-ENTRY-FUNCTION COM))) (QUOTE (\, INPUT)) (QUOTE (\, ENVIRONMENT)))))) (SETQ ADD-TO-SPELLING-LIST NIL) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT))))) (T (* ;; "Handle non-exec commands (fns, functions, macros, etc.).") (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) INPUT)) (CL:WHEN *EXEC-MAKE-UNDOABLE-P* (if (CDR TODO) then (SETQ TODO (CONS (OR (CDR (ASSOC (CAR TODO) LISPXFNS)) (CAR TODO)) (CDR TODO))) else (SETQ TODO (LIST (XCL::MAKE-UNDOABLE (CAR TODO) NIL))))))) (AND ADD-TO-SPELLING-LIST (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ LISPXHIST *CURRENT-EVENT*) (DSPFONT PRINTOUTFONT T) (RETURN (LET ((HELPCLOCK (CLOCK 2)) VALUES) (DECLARE (CL:SPECIAL HELPCLOCK)) (CL:SETQ CL:+++ CL:++ CL:++ + + - - (CAR INPUT)) (* ;; "the book doesn't define what - and friends should be when input is in APPLY format.  Here it says it is just the function name.") (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (CL:IF RETRYFLAG (LET ((HELPFLAG (QUOTE BREAK!))) (DECLARE (CL:SPECIAL HELPFLAG)) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)) (CL:FUNCALL FUNCTION TODO ENVIRONMENT)))) (CL:SETQ CL:/// CL:// CL:// / / VALUES) (CL:UNLESS (EQ (QUOTE NOBIND) (CAR VALUES)) (* ; "Be a bit careful about NOBIND.") (CL:SETQ CL:*** CL:** CL:** CL:* CL:* (SETQ IT (CAR VALUES)))) (CL:WHEN *CURRENT-EVENT* (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (CAR VALUES)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*)))) (DSPFONT VALUEFONT T) (for X in VALUES do (EXEC-PRINT X)) VALUES))))
+
+(CL:DEFUN EXEC (&KEY XCL::TOP-LEVEL-P (* ; "True of top level execs.  Used for event number restarting and profile caching.") (XCL::WINDOW (WFROMDS (TTYDISPLAYSTREAM))) (* ; "Window for this exec, if any.") (XCL::TITLE NIL XCL::TITLE-SUPPLIED) (* ; "If given, specific title for this window.") ((:COMMAND-TABLES *THIS-EXEC-COMMANDS*) (LIST *EXEC-COMMAND-TABLE*)) (* ; "List of hash tables to look up commands in.") XCL::ENVIRONMENT (* ; "Lexical environment to evaluate things in, default NIL.") XCL::PROMPT (* ; "Special prompt to use (optional).") ((:FUNCTION XCL::FN) (QUOTE EVAL-INPUT)) (* ; "Function for processing input.") XCL::PROFILE (* ; "Optional profile, sets the exec's bindings.") XCL::ID (* ; "A handle on the exec.") &ALLOW-OTHER-KEYS (* ; "To catch obsolete calls") &AUX (*EXEC-ID* (PROCESS-EXEC-ID (THIS.PROCESS) XCL::ID)) (XCL::PROFILE-CACHE (XCL::GET-PROCESS-PROFILE (THIS.PROCESS))) (* ; "The exec's cached profile (if entering from a hardreset).")) (CL:PROGV (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION CAR)) (MAPCAR *PER-EXEC-VARIABLES* (FUNCTION (LAMBDA (XCL::X) (EVAL (CADR XCL::X))))) (CL:WHEN (OR (NULL XCL::TOP-LEVEL-P) (NULL XCL::PROFILE-CACHE)) (* ; "If not hardresetting...") (CL:WHEN XCL::PROFILE (* ; "then initialize the profile vars.") (XCL:RESTORE-PROFILE XCL::PROFILE)) (CL:WHEN XCL::PROMPT (* ; "If a special prompt was provided (as from the debugger)...") (CL:SETQ XCL:*EXEC-PROMPT* XCL::PROMPT) (* ; "...use it."))) (CL:WHEN XCL::TOP-LEVEL-P (CL:IF (NULL XCL::PROFILE-CACHE) (* ; "This was a new entry into top level exec.") (CL:SETF (XCL::GET-PROCESS-PROFILE (THIS.PROCESS)) (XCL:SAVE-PROFILE (XCL:COPY-PROFILE "EXEC"))) (* ; "...make a fresh cache and save bindings into it.") (XCL:RESTORE-PROFILE XCL::PROFILE-CACHE) (* ; "...otherwise it was a HARDRESET."))) (CL:WHEN XCL::WINDOW (COND ((NOT XCL::TITLE-SUPPLIED) (* ; "If no title was supplied, set it to the default.") (XCL::EXEC-TITLE-FUNCTION XCL::WINDOW *EXEC-ID*)) (XCL::TITLE (* ; "If a non-nil title was supplied, set the title to it.") (WINDOWPROP XCL::WINDOW (QUOTE TITLE) XCL::TITLE))) (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW))) (LET ((*CURRENT-EVENT* NIL) (* ; "the event being processed. Used by some commands") (XCL::OLD-DS (CL:IF XCL::WINDOW (TTYDISPLAYSTREAM (DECODE/WINDOW/OR/DISPLAYSTREAM XCL::WINDOW))))) (CL:LOOP (CL:FORMAT T "~&~%%") (* ; "newlines to notice that this is a new instance of the exec") (PROG1 (ERSETQ (CL:LOOP (* ; "loop until errors out") (CL:SETQ *CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY *EXEC-ID* XCL:*EXEC-PROMPT* (NOT XCL::TOP-LEVEL-P))) (* ; "This optimization keeps HARDRESET from generating all new event numbers for all execs that are open.") (PRINT-EVENT-PROMPT *CURRENT-EVENT*) (DSPFONT INPUTFONT T) (LET ((XCL::ORIGINAL-INPUT (EXEC-READ-LINE)) (LISPXHIST LISPXHIST) (HELPCLOCK 0)) (DECLARE (CL:SPECIAL LISPXHIST HELPCLOCK)) (CL:UNLESS (CL:EQUAL XCL::ORIGINAL-INPUT (QUOTE (NIL))) (DO-EVENT XCL::ORIGINAL-INPUT XCL::ENVIRONMENT XCL::FN) (CL:WHEN XCL::TOP-LEVEL-P (* ; "Used to determine whether to cache the settings of the profile back into the process (for retrieval in case of hardreset).") (XCL::SAVE-CURRENT-EXEC-PROFILE)))))) (CL:WHEN XCL::WINDOW (TTYDISPLAYSTREAM XCL::OLD-DS)))))))
+
+(CL:DEFUN EXEC-EVAL (FORM &OPTIONAL ENVIRONMENT &KEY (PROMPT ">") (ID "eval/") ((:TYPE *CURRENT-EXEC-TYPE*) (QUOTE COMMON-LISP))) (* ; "Edited by JDS 16-Aug-90 12:55.") (LET ((*CURRENT-EVENT* (GET-NEXT-HISTORY-EVENT LISPXHISTORY ID PROMPT T)) (LISPXHIST LISPXHIST) (HELPCLOCK 0) VALUES) (DECLARE (CL:SPECIAL *CURRENT-EVENT* LISPXHIST HELPCLOCK)) (SETQ VALUES (CL:MULTIPLE-VALUE-LIST (EVAL-INPUT (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (LIST FORM)) ENVIRONMENT))) (SETQ IT (CAR VALUES)) (COND (*CURRENT-EVENT* (* ;; "Only update the current event if it's not NIL.  This might happen, e.g., if LISPXHIST has been set to NIL by the user.") (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS *CURRENT-EVENT*))) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) IT))) (CL:VALUES-LIST VALUES)))
+
+(CL:DEFUN PRINT-ALL-DOCUMENTATION (NAME) "Print all documentation strings for NAME (as symbol and string)." (LET ((FOUND NIL)) (CL:DOLIST (TYPE FILEPKGTYPES) (CL:WHEN (AND (CL:SYMBOLP TYPE) (GET TYPE (QUOTE DEFINED-BY)) (HASH-TABLE-FOR-DOC-TYPE TYPE)) (SETQ FOUND (OR (PRINT-DOCUMENTATION NAME TYPE) FOUND)) (CL:WHEN (CL:SYMBOLP NAME) (SETQ FOUND (OR (PRINT-DOCUMENTATION (STRING NAME) TYPE) FOUND))))) (CL:UNLESS FOUND (CL:FORMAT *TERMINAL-IO* "No documentation found.~%%"))))
+
+(CL:DEFUN PRINT-DOCUMENTATION (NAME TYPE) "If it exists, print documentation for NAME as TYPE.  Returns T if doc was found, else NIL." (LET ((DOC (CL:DOCUMENTATION NAME TYPE))) (AND DOC (TRUE (CL:FORMAT *TERMINAL-IO* "~&~A (~A)" DOC (OR (CL:DOCUMENTATION NAME (QUOTE DEFINE-TYPES)) TYPE))))))
+
+(DEFMACRO VALUE-OF (&REST EVENT-SPEC) (BQUOTE (EXEC-VALUE-OF (QUOTE (\, EVENT-SPEC)))))
+
+(CL:DEFUN ADD-EXEC (&KEY (XCL::PROFILE XCL:*PROFILE*) XCL::REGION XCL::TTY (EXEC (QUOTE EXEC)) XCL::ID &ALLOW-OTHER-KEYS) (LET* ((XCL::WINDOW (XCL::SETUP-EXEC-WINDOW (CREATEW XCL::REGION "Exec"))) (XCL::HANDLE (ADD.PROCESS (BQUOTE (PROGN (TTYDISPLAYSTREAM (QUOTE (\, XCL::WINDOW))) (PROCESSPROP (THIS.PROCESS) (QUOTE WINDOW) (QUOTE (\, XCL::WINDOW))) (\, (CASE EXEC (EXEC (BQUOTE (EXEC :TOP-LEVEL-P T :PROFILE (QUOTE (\, XCL::PROFILE)) :ID (QUOTE (\, XCL::ID))))) (T (BQUOTE (XCL::ENTER-EXEC-FUNCTION (QUOTE (\, EXEC)) (QUOTE (\, XCL::PROFILE)) (QUOTE (\, XCL::ID))))))))) (QUOTE NAME) (QUOTE EXEC) (QUOTE RESTARTABLE) T))) (AND XCL::TTY (TTY.PROCESS XCL::HANDLE)) XCL::HANDLE))
+
+(CL:DEFUN EXEC-READ-LINE (&OPTIONAL BUFFER-STRING) (* ;; "Code stolen from READLINE, and not cleaned up. ") (PROG (LINE SPACEFLG CHRCODE (*IN-THE-DEBUGGER* NIL)) (COND ((AND (READP T) (SYNTAXP (PEEKCCODE T T) (QUOTE EOL))) (* ; "Avoid picking up end of line as a NIL.") (READC T))) (SETQ LINE (LIST (EXEC-READ BUFFER-STRING))) TOP (COND ((LISTP (CAR LINE)) (* ; "If we got a list, return right away--it's a standard EVAL form of input") (GO OUT))) LP (SETQ SPACEFLG NIL) (* ; "to distinguish between") (* ; "FOO (A B)") (* ; "FOO(A B)") (* ; "the latter has no space and returns right away") LP1 (COND ((NOT (READP T)) (* ; "nothing more in line buffer, so must have consumed last thing on the line") (GO OUT)) ((NULL (SETQ CHRCODE (PEEKCCODE T T))) (* ; "PEEKCCODE can return NIL when stream is at EOF.  However, we already checked for READP before getting here.") (GO OUT)) ((SYNTAXP CHRCODE (QUOTE EOL)) (READC T) (GO OUT)) ((OR (SYNTAXP CHRCODE (QUOTE RIGHTPAREN) *READTABLE*) (SYNTAXP CHRCODE (QUOTE RIGHTBRACKET) *READTABLE*)) (AND (READ T *READTABLE*) (SHOULDNT)) (AND (NULL (CDR LINE)) (SETQ LINE (NCONC1 LINE NIL))) (* ; " A %")%" is treated as NIL if it is the second thing on the line when EXEC-READ-LINE is called") (GO OUT)) ((EQ CHRCODE (CHARCODE SPACE)) (SETQ SPACEFLG T) (READC T) (GO LP1))) (SETQ LINE (NCONC1 LINE (EXEC-READ))) (COND ((NULL (OR (SYNTAXP (SETQ CHRCODE (CHCON1 (LASTC T))) (QUOTE RIGHTPAREN) *READTABLE*) (SYNTAXP CHRCODE (QUOTE RIGHTBRACKET) *READTABLE*))) (GO LP)) ((NOT SPACEFLG) (* ; "A list terminates the line if it is the second element on the line, not preceded by a space.") (* ;; "[JDS 1/12/88:  This used to test (AND (NOT SPACEFLG) (READP T)), and loop if there were more input pending.  This seems wrong, because when you type it should throw the carriage at once, and not depend on how fast you're typing.  Further, when there's type-ahead, it's often followed by a SPACE, to prevent output pausing.  With the old test here, that would hang up a final eval-quote form without executing it.]") (GO OUT)) (T (GO LP))) (GO LP) OUT (RETURN (COND ((AND (LISTP LINE) CTRLUFLG) (* ; "Edit interrupt during reading--forces structure editor use.") (SETQ CTRLUFLG NIL) (LET ((*EDIT-INPUT-WITH-TTYIN* NIL)) (FIX-FORM LINE))) (T LINE)))))
+
+(DEFMACRO EXEC-EVENT-ID-PROMPT (EVENT-ID) (BQUOTE (CDDR (\, EVENT-ID))))
+
+(CL:DEFUN FIND-EXEC-COMMAND (NAME TABLE) "Find an exec command based on its name (either a string or a symbol).  Returns the command entry or NIL if not found." (CL:WHEN (OR (CL:STRINGP NAME) (CL:SYMBOLP NAME)) (LET ((STR (CL:IF (CL:SYMBOLP NAME) (CL:SYMBOL-NAME NAME) NAME))) (CL:SOME (CL:FUNCTION (CL:LAMBDA (TABLE) (SETQ COM (GETHASH STR TABLE)))) TABLE))))
+
+(CL:DEFUN CIRCLAR-COPYER (INPUT) (* ; "Edited by TT 31-May-1990") (PROG (SCANBUF REST VAL NEW BODY ID AUX (CIRCLAR-FLAG NIL)) (COND ((NLISTP INPUT) (RETURN INPUT)) (T (push SCANBUF (CONS INPUT (SETQ VAL (CONS NIL NIL)))) (push REST VAL) (RPLACA VAL (CAR INPUT)) (RPLACD VAL (CDR INPUT)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))"))) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 (COND ((NULL BODY) (RETURN (CL:VALUES VAL CIRCLAR-FLAG))) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACD NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW)))) (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (SETQ CIRCLAR-FLAG T) (RPLACA NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW)))) (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX))))) (GO LP)))
+(DEFINEQ
+
+(COPY-CIRCLE

+(LAMBDA (X) (* ; "Edited 23-May-90 15:02 by Tomtom") (PROG (SCANBUF REST VAL NEW BODY ID AUX) (COND ((NLISTP X) (RETURN X)) (T (push SCANBUF (CONS X (SETQ VAL (CONS NIL NIL)))) (push REST VAL) (RPLACA VAL (CAR X)) (RPLACD VAL (CDR X)) (* ;;; "(COND ((EQ X (CAR X)) (RPLACA VAL VAL)) (T (RPLACA VAL (CAR X)))) (COND ((EQ X (CDR X)) (RPLACD VAL VAL)) (T (RPLACD VAL (CDR X))))"))) (* ; "Initialization is over") LP (SETQ BODY (pop REST)) LP0 (COND ((NULL BODY) (RETURN VAL)) ((NLISTP BODY) (GO LP)) (T (SETQ NEW BODY) (COND ((NLISTP (CDR NEW))) ((SETQ ID (FASSOC (CDR NEW) SCANBUF)) (RPLACD NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CADR NEW) (CDDR NEW)))) (push SCANBUF (CONS (CDR NEW) AUX)) (RPLACD NEW AUX))) (COND ((NLISTP (CAR NEW))) ((SETQ ID (FASSOC (CAR NEW) SCANBUF)) (RPLACA NEW (CDR ID))) (T (push REST (SETQ AUX (CONS (CAAR NEW) (CDAR NEW)))) (push SCANBUF (CONS (CAR NEW) AUX)) (RPLACA NEW AUX))))) (GO LP)))
+)
+)
+
+
+
+(* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172")

+
+(DEFINEQ
+
+(EXEC-READ

+  [CL:LAMBDA (&OPTIONAL BUFFER-STRING)
                   (* ; "Edited  4-Feb-88 18:22 by amd")

+
+(* ;;; "Reads structure from the user (in the exec), taking care to handle read errors so that they will be edited and fixed.")

+
+         (HANDLER-BIND [[XCL:SYMBOL-COLON-ERROR #'(LAMBDA (CONDITION)
+                                                    (DECLARE
 (CL:SPECIAL CTRLUFLG))
+                                                    (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                    (SETQ CTRLUFLG T)
+                                                    (XCL::ESCAPE-COLONS-PROCEED)
+                                                    (SHOULDNT 
+                                                           "Didn't find XCL::ESCAPE-COLONS-PROCEED"]
+                        [XCL:MISSING-EXTERNAL-SYMBOL #'(LAMBDA (CONDITION)
+                                                         (DECLARE
 (CL:SPECIAL CTRLUFLG))
+                                                         (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                         (SETQ CTRLUFLG T)
+                                                         (XCL:MAKE-INTERNAL-PROCEED)
+                                                         (SHOULDNT 
+                                                              "Didn't find XCL:MAKE-INTERNAL-PROCEED"
+                                                                ]
+                        (XCL:MISSING-PACKAGE #'(LAMBDA (CONDITION)
+                                                 (DECLARE
 (CL:SPECIAL CTRLUFLG))
+                                                 (CL:FORMAT *TERMINAL-IO* "~a~%%" CONDITION)
+                                                 (SETQ CTRLUFLG T)
+                                                 (XCL:UGLY-SYMBOL-PROCEED)
+                                                 (SHOULDNT "Didn't find XCL:UGLY-SYMBOL-PROCEED"]
+                (COND
+                   ([OR (NOT (GETD 'TTYIN))
+                        (NOT *EDIT-INPUT-WITH-TTYIN*)
+                        (NOT (DISPLAYSTREAMP (GETSTREAM T 'OUTPUT]
+                                                             (* ; 
+
                                                 "If debugging and TTYIN breaks, don't want to die")

+
+                    (CL:READ T))
+                   (T (LET (X)
+                           (COND
+                              ((OR (LINEBUFFER-SKIPSEPRS T *READTABLE*)
+                                   (until
 (SETQ X (TTYIN "" NIL NIL '(EVALQT FILLBUFFER NOPROMPT) 
+                                                             NIL NIL BUFFER-STRING *READTABLE*))
+                                      do
 
+          
+          (* ;; "Until he types something at all, keep printing the event-number prompt.")

+
+                                            (PRINT-EVENT-PROMPT
 *CURRENT-EVENT*)
+                                            (DSPFONT INPUTFONT T))
+                                   (EQ X T))
+                               (CL:READ-PRESERVING-WHITESPACE T))
+                              (T (CAR X])
+
+(DIR

+  [NLAMBDA ARGS                                              (* ; "Edited 12-Mar-87 16:08 by raf")
+
+    (DODIR
 ARGS])
+)
+
+(CL:DEFPARAMETER *PER-EXEC-VARIABLES* (QUOTE ((CL:* CL:*) (CL:** CL:**) (CL:*** CL:***) (+ +) (CL:++ CL:++) (CL:+++ CL:+++) (- -) (/ /) (CL:// CL://) (CL:/// CL:///) (HELPFLAG T) (*EVALHOOK* NIL) (*APPLYHOOK* NIL) (*ERROR-OUTPUT* *TERMINAL-IO*) (*READTABLE* *READTABLE*) (*PACKAGE* *PACKAGE*) (XCL:*EVAL-FUNCTION* XCL:*EVAL-FUNCTION*) (XCL:*EXEC-PROMPT* XCL:*EXEC-PROMPT*) (XCL:*DEBUGGER-PROMPT* XCL:*DEBUGGER-PROMPT*))) "List of (non-profile) variables rebound for each Exec")
+
+(CL:DEFVAR CL:* NIL)
+
+(CL:DEFVAR CL:** NIL)
+
+(CL:DEFVAR CL:*** NIL)
+
+(CL:DEFVAR + NIL)
+
+(CL:DEFVAR CL:++ NIL)
+
+(CL:DEFVAR CL:+++ NIL)
+
+(CL:DEFVAR - NIL)
+
+(CL:DEFVAR / NIL "Holds a list of all the values returned by the most recent top-level EVAL.")
+
+(CL:DEFVAR CL:// NIL "Gets the previous value of / when a new value is computed.")
+
+(CL:DEFVAR CL:/// NIL "Gets the previous value of // when a new value is computed.")
+
+(CL:DEFVAR *CURRENT-EVENT* NIL "contains the current event being processed. Used for communicating between Exec and commands")
+
+(CL:DEFVAR *EXEC-ID* NIL "A unique per-exec-process ID so that commands that search the history list can find this Exec's events")
+
+(CL:DEFVAR XCL:*EXEC-PROMPT* "> " "Default prompt used by exec")
+
+(CL:DEFPARAMETER XCL:*EVAL-FUNCTION* (QUOTE CL:EVAL) "The evaluator to use in the exec")
+
+(CL:DEFVAR *NOT-YET-EVALUATED* "<not yet evaluated>")
+
+(CL:DEFVAR *THIS-EXEC-COMMANDS* NIL "List of command hash-tables for the current executive")
+
+(DEFGLOBALVAR *EXEC-COMMAND-TABLE* (HASHARRAY 30 NIL (QUOTE STRING-EQUAL-HASHBITS) (QUOTE STRING-EQUAL)) "hash-table for top level exec commands")
+
+(DEFGLOBALVAR *DEBUGGER-COMMAND-TABLE* (HASHARRAY 20 NIL (QUOTE STRING-EQUAL-HASHBITS) (QUOTE STRING-EQUAL)) "string-equal hash-table for debugger commands")
+
+(CL:DEFVAR *CURRENT-EXEC-TYPE* NIL "Rebound under Exec; if NIL, means use default")
+
+(CL:DEFPARAMETER *EXEC-MAKE-UNDOABLE-P* T "global parameter controls whether the exec makes input undoable")
+
+(CL:DEFVAR *EDIT-INPUT-WITH-TTYIN* T)
+(DEFINEQ
+
+(DO-APPLY-EVENT

+  [LAMBDA (TODO)                                             (* lmm "31-Jul-86 03:22")
+    (CL:IF
 (CL:MACRO-FUNCTION
 (CAR
 TODO))
+           (CL:IF
 (EQ
 (ARGTYPE
 (CAR
 TODO))
+                             3)
+                  (CL:FUNCALL
 (CAR
 TODO)
+                         (CL:IF
 (CDDR
 TODO)
+                                (CDR
 TODO)
+                                (CADR
 TODO)))
+                  (CL:EVAL
 TODO))
+           (CL:APPLY
 (CAR
 TODO)
+                  (CADR
 TODO])
+
+(DO-HISTORY-SEARCH

+  [LAMBDA (SPEC PRED-P VALUE-P)                              (* ; "Edited 10-Mar-87 18:53 by raf")
+          
+          (* ;; 
+          "SEARCHES HISTORY LIST, LOOKING FOR SPEC AND RESETTING *EVENTS* TO THE CORRESPONDING TAIL.")
+
+    (PROG
 (PAT1 PAT2 TEM PRED)
+              (DECLARE
 (CL:SPECIAL *EVENTS*))            (* ; "Setup by FIND-HISTORY-EVENTS")
+
+              [COND

+                 ((NOT
 PRED-P)
+                  (SETQ
 PAT2 (EDITFPAT
 SPEC T]
+          LP  [COND

+                 ((EQ
 (CAR
 *EVENTS*)
+                         *CURRENT-EVENT*)
+                  (SETQ
 *EVENTS* (CDR
 *EVENTS*]
+              [COND

+                 ((COND

+                     (PRED-P (APPLY*
 SPEC (CAR
 *EVENTS*)))
+                     [PAT1 (EDIT4E
 PAT1 (CAR
 (EXEC-EVENT-INPUT
 (CAR
 *EVENTS*]
+                     (T (EDITFINDP
 [COND

+                                          (VALUE-P (CL:GETF
 (EXEC-EVENT-PROPS (CAR
 *EVENTS*))
+                                                          'LISPXVALUES))
+                                          (T (EXEC-EVENT-INPUT
 (CAR
 *EVENTS*]
+                               PAT2 T)))
+                  (RETURN
 *EVENTS*))
+                 (T (SETQ
 *EVENTS* (CDR
 *EVENTS*]
+          LP1 (COND

+                 ((NULL
 *EVENTS*)
+                  (RETURN
 NIL)))
+              (GO
 LP])
+
+(EVAL-INPUT

+  [CL:LAMBDA
+   (TODO ENV)                                                (* ; "Edited 23-Nov-87 13:07 by raf")
+
+   (CASE XCL:*EVAL-FUNCTION*
+         [EVAL
                                           (* ; "Interlisp EVAL")
+
+                (COND

+                   [(CDR
 TODO)                           (* ; "this is the 'apply' case")
+          
+          (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)")
+
+                    (if [OR
 (CDDR
 TODO)
+                               (AND
 (CADR
 TODO)
+                                      (NLISTP
 (CADR
 TODO]
+                        then
+                        (if (FMEMB
 (ARGTYPE
 (CAR
 TODO))
+                                   '(1 3))
+                            then                             (* ; 
+                                  "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).")
+
+                            [if (AND
 (EQ
 (ARGTYPE
 (CAR
 TODO))
+                                                3)
+                                       (CDDR
 TODO))
+                                then
+                                (APPLY
 (CAR
 TODO)
+                                       (CDR
 TODO))
+                                else
+                                (if (CDDR
 TODO)
+                                    then
+                                    (PRIN1
 "... = ")
+                                    (PRINT
 TODO)
+                                    (APPLY
 (CAR
 TODO)
+                                           (CDR
 TODO))
+                                    else
+                                    (APPLY
 (CAR
 TODO)
+                                           (CADR
 TODO]
+                            else
+          
+          (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g.  a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case")
+
+                            (EVAL
 TODO))
+                        else                                 (* ; "a normal apply case")
+
+                        (if (CDDR
 TODO)
+                            then
+                            (PRIN1
 "... = ")
+                            (PRINT
 TODO)
+                            (APPLY
 (CAR
 TODO)
+                                   (MAPCAR
 (CDR
 TODO)
+                                          (FUNCTION
 EVAL)))
+                            else
+                            (APPLY
 (CAR
 TODO)
+                                   (CADR
 TODO]
+                   (T                                        (* ; "a normal eval case")
+
+                      (EVAL
 (CAR
 TODO]
+         (T                                                  (* ; "Common Lisp EVAL")
+          
+          (* ;; "maybe should have used ECASE and checked for Common-Lisp explicitly, but could get recursive errors if *current-exec-type* was rebound")
+
+            (COND

+               [(CDR
 TODO)                               (* ; "this is the 'apply' case")
+          
+          (* ;; "we first check for input of things like macros in apply format or Interlisp NLAMBDA functions (which have a MACRO-FUNCTION)")
+
+                (COND

+                   [(CL:MACRO-FUNCTION
 (CAR
 TODO))
+                    (COND

+                       [(FMEMB
 (ARGTYPE
 (CAR
 TODO))
+                               '(1 3))                       (* ; 
+                                  "this is an Interlisp NLAMBDA function (1 = spread, 3 = nospread).")
+
+                        (COND

+                           ((AND
 (EQ
 (ARGTYPE
 (CAR
 TODO))
+                                            3)
+                                   (CDDR
 TODO))
+                            (APPLY
 (CAR
 TODO)
+                                   (CDR
 TODO)))
+                           (T (COND

+                                 ((CDDR
 TODO)
+                                  (PRIN1
 "... = ")
+                                  (PRINT
 TODO)
+                                  (APPLY
 (CAR
 TODO)
+                                         (CDR
 TODO)))
+                                 (T (APPLY
 (CAR
 TODO)
+                                           (CADR
 TODO]
+                       (T 
+          
+          (* ;; "evaluate the entire input list as if it were typed in with parens around it, e.g.  a 'FOR I FROM 1 TO 10 DO ...' possibly bogus 'DWIM' case")
+
+                          (CL:EVAL
 TODO ENV]
+                   (T                                        (* ; "a normal apply case")
+
+                      (COND

+                         [(CDDR
 TODO)
+                          (PRIN1
 "... = ")
+                          (PRINT
 TODO)
+                          (CL:APPLY
 (CAR
 TODO)
+                                 (CL:MAPCAR
 #'(CL:LAMBDA (A)
+                                                         (CL:EVAL
 A ENV)) (CDR
 TODO]
+                         (T (CL:APPLY
 (CAR
 TODO)
+                                   (CADR
 TODO]
+               (T                                            (* ; "a normal eval case")
+
+                  (CL:EVAL
 (CAR
 TODO)
+                         ENV])
+
+(EVENTS-INPUT

+  [CL:LAMBDA (EVENTS)                                        (* ; "Edited 26-Nov-86 11:16 by lmm")
+                                                             (* ; 
+     "takes a list of events and returns the input concatenated into a single event, as appropriate ")
+
+         (IF (CDR
 EVENTS)
+             THEN
+             [CONS
 'DO-EVENTS (FOR EVENT IN EVENTS COLLECT (IF (CDR
 (EXEC-EVENT-INPUT

+                                                                             EVENT))
+                                                                   THEN
+                                                                   (CONS
 'EVENT (
+
                                                                                   EXEC-EVENT-INPUT

+                                                                                     EVENT))
+                                                                   ELSE
+                                                                   (CAR
 (EXEC-EVENT-INPUT

+                                                                             EVENT]
+             ELSE
+             (LET*
 ((INPUT
 (EXEC-EVENT-INPUT
 (CAR
 EVENTS)))
+                        (TAIL (FMEMB
 HISTSTR0 INPUT)))
+                    (IF TAIL THEN (LDIFF
 INPUT TAIL)
+                        ELSE INPUT])
+
+(EXEC-PRIN1

+  (CL:LAMBDA (VALUE)                                         (* ; "Edited 23-Feb-87 18:15 by raf")
+
+         (WRITE
 VALUE :STREAM *TERMINAL-IO* :ESCAPE T)))
+
+(EXEC-VALUE-OF

+  [LAMBDA (EVENT-SPEC)                                       (* lmm "11-Sep-86 17:28")
+    (CL:VALUES-LIST
 (LISTGET
 (EXEC-EVENT-PROPS (CAR
 (FIND-HISTORY-EVENTS
 EVENT-SPEC 
+                                                                       LISPXHISTORY)))
+                               'LISPXVALUES])
+
+(GET-NEXT-HISTORY-EVENT

+  [LAMBDA (HISTORY ID PROMPT FIRST-ONLY)                     (* ; "Edited  2-Mar-87 15:34 by raf")
+
+    (for EVENT in (HISTORY-EVENTS
 HISTORY)
+         do
+         (CL:WHEN (EQ
 (CADR
 (LISTP
 (EXEC-EVENT-ID
 EVENT)))
+                         ID)
+                (CL:IF
 (AND
 (NULL
 (EXEC-EVENT-INPUT
 EVENT))
+                                  (NULL
 (EXEC-EVENT-PROPS EVENT)))
+                       (PROGN
 (CL:SETF (CDDR
 (EXEC-EVENT-ID
 EVENT))
+                                         PROMPT)
+                              (RETURN
 EVENT))
+                       (GO
 $$OUT)))
+         (if FIRST-ONLY then                                 (* ; "only do this for the first event")
+
+             (GO
 $$OUT))
+         finally
+         (COND

+            (HISTORY                                         (* ; "Watch out for NIL LISPXHISTORY")
+
+                   (SETQ
 EVENT (MAKE-EXEC-EVENT
 :ID (LIST*
 (CL:INCF (HISTORY-INDEX

+                                                                                 HISTORY))
+                                                                   ID PROMPT)))
+                   (CL:PUSH EVENT (HISTORY-EVENTS
 HISTORY))
+                   (CL:SETF (CDR
 (CL:NTHCDR
 (CL:1-
 (HISTORY-SIZE
 HISTORY))
+                                            (HISTORY-EVENTS
 HISTORY)))
+                          NIL)
+                   (RETURN
 EVENT])
+
+(HISTORY-ADD-TO-SPELLING-LISTS

+  [LAMBDA (INPUT
)                                        (* lmm "31-Jul-86 02:22")
+    (COND

+       ((CDR
 INPUT)                                      (* ; 
+                                                    "Add to the spelling list if it has a definition")
+
+        (AND
 (LITATOM
 (CAR
 INPUT))
+               (FGETD
 (CAR
 INPUT))
+               (ADDSPELL
 (CAR
 INPUT)
+                      2)))
+       ([AND
 (CL:CONSP
 (CAR
 INPUT))
+               (LITATOM
 (CAR
 (CAR
 INPUT]         (* ; "looks like a valid function")
+
+        (AND
 [OR
 (CL:FBOUNDP
 (CAR
 (CAR
 INPUT)))
+                        (CL:SPECIAL-FORM-P
 (CAR
 (CAR
 INPUT]
+               (ADDSPELL
 (CAR
 (CAR
 INPUT))
+                      2)))
+       ((AND
 (CL:SYMBOLP
 (CAR
 INPUT))
+               (BOUNDP
 (CAR
 INPUT)))
+        (ADDSPELL
 (CAR
 INPUT)
+               3])
+
+(HISTORY-NTH

+  [LAMBDA (LST N ID)                                         (* lmm " 6-Nov-86 01:40")
+    (bind EVENT while LST do (if (<=
 N 0)
+                                 then
+                                 (RETURN
))
+          (SETQ
 EVENT (CAR
 LST))
+          (CL:IF
 (AND
 (EXEC-EVENT-INPUT
 EVENT)
+                            (NEQ
 EVENT *CURRENT-EVENT*)
+                            (OR
 (NOT
 (STRINGP
 ID))
+                                   (EQ
 (CADR
 (LISTP
 (EXEC-EVENT-ID
 EVENT)))
+                                          ID)))
+                 (if (<=
 (CL:DECF N)
+                      0)
+                     then
+                     (RETURN
 LST)))
+          (pop LST])
+
+(PRINT-HISTORY

+  [CL:LAMBDA (HISTORY EVENT-SPECS &OPTIONAL NOVALUES)        (* lmm " 5-Nov-86 23:29")
+         (PROG
 [HELPCLOCK (EVENTS (CL:IF
 EVENT-SPECS (FIND-HISTORY-EVENTS
 EVENT-SPECS 
+                                                                    HISTORY)
+                                             (HISTORY-EVENTS
 HISTORY]
+                   (TERPRI
 T)
+                   (for X in EVENTS do (PRINT-EVENT
 X NOVALUES)
+                        (FRESHLINE
 T)
+                        (TERPRI
 T))
+                   (TERPRI
 T)
+                   (RETURN
 (CL:VALUES
])
+
+(FIND-HISTORY-EVENTS

+  [LAMBDA (EVENT-SPEC HISTORY)                               (* ; "Edited  6-Nov-87 15:22 by raf")
+
+    (PROG
 [(*EVENTS* (HISTORY-EVENTS
 HISTORY))
+               (ORIGINAL-EVENT-SPEC EVENT-SPEC)
+               SPEC TEM VALUE-P VAL PRED-P ALL-P (AND-SPEC (CL:MEMBER
 "AND" EVENT-SPEC :TEST
+                                                                  'STRING.EQUAL]
+              (DECLARE
 (CL:SPECIAL *EVENTS*))            (* ; "Used by DO-HISTORY-SEARCH")
+
+              [if AND-SPEC then (RETURN
 (APPEND
 (SETQ
 *EVENTS* (FIND-HISTORY-EVENTS

+                                                                            (LDIFF
 EVENT-SPEC 
+                                                                                   AND-SPEC)
+                                                                            HISTORY))
+                                                   (for X in (FIND-HISTORY-EVENTS
 (CDR
 
+                                                                                             AND-SPEC
+                                                                                             )
+                                                                    HISTORY)
+                                                        when
+                                                        (NOT
 (FMEMB
 X *EVENTS*))
+                                                        collect X]
+          LP  (CL:WHEN (EQ
 (CAR
 *EVENTS*)
+                              *CURRENT-EVENT*)
+                     (SETQ
 *EVENTS* (CDR
 *EVENTS*)))
+              [CASE-EQUALP (SETQ
 SPEC (CAR
 EVENT-SPEC))
+                     (ALL (SETQ
 ALL-P T)
+                          (pop EVENT-SPEC)
+                          (GO
 LP))
+                     (F [COND

+                           ((SETQ
 TEM (CDR
 EVENT-SPEC))
+                                                             (* ; 
+        "Otherwise, F is not a special symbol, e.g.  user types REDO F, meaning search for F itself.")
+
+                            (SETQ
 EVENT-SPEC (CDR
 EVENT-SPEC))
+                            (SETQ
 SPEC (CAR
 EVENT-SPEC]
+                        (DO-HISTORY-SEARCH
 SPEC PRED-P VALUE-P))
+                     [FROM (LET
 ((EVENTS (FIND-HISTORY-EVENTS
 (CDR
 EVENT-SPEC)
+                                                    HISTORY)))
+                                  (CL:WHEN (CDR
 EVENTS)
+                                         (ERROR
 "from?"))
+                                  (RETURN
 (REVERSE
 (LDIFF
 *EVENTS*
+                                                                  (CDR
 (CL:MEMBER

+                                                                            (CAR
 EVENTS)
+                                                                            *EVENTS*]
+                     (SUCHTHAT 
+          
+          (* ;; "What follows SUCHTHAT is a function to be applied to the entire event;  and if true, approves that event.")
+
+                            (SETQ
 PRED-P T)
+                            (SETQ
 EVENT-SPEC (CDR
 EVENT-SPEC))
+                            (SETQ
 SPEC (CAR
 EVENT-SPEC))
+                            (DO-HISTORY-SEARCH
 SPEC PRED-P VALUE-P))
+                     (=
 (SETQ
 VALUE-P T)
+                            (GO
 LP))
+                     (T (COND

+                           ((NOT
 (CL:INTEGERP
 SPEC))
+                            (DO-HISTORY-SEARCH
 SPEC PRED-P VALUE-P)
+                                                             (* ; "Does searching.")
+
+                            )
+                           [(<
 SPEC 0)                   (* ; "count backward")
+
+                            (SETQ
 *EVENTS* (HISTORY-NTH
 *EVENTS* (-
 SPEC)
+                                                      (AND
 (NOT
 ALL-P)
+                                                             *EXEC-ID*]
+                           (T                                (* ; "absolute event number")
+
+                              (SETQ
 *EVENTS* (SEARCH-FOR-EVENT-NUMBER
 *EVENTS* HISTORY SPEC]
+              [COND

+                 ((NULL
 *EVENTS*)
+                  (COND

+                     (ALL-P (RETURN
 VAL)))
+                  (ERROR
 SPEC '" ?" T))
+                 ((NULL
 (SETQ
 EVENT-SPEC (CDR
 EVENT-SPEC)))
+                  (COND

+                     [(NULL
 ALL-P)
+                      (RETURN
 (LIST
 (CAR
 *EVENTS*]
+                     (T (SETQ
 VAL (NCONC1
 VAL (CAR
 *EVENTS*)))
+                        (SETQ
 EVENT-SPEC ORIGINAL-EVENT-SPEC]
+              (SETQ
 *EVENTS* (CDR
 *EVENTS*))
+              (CL:WHEN (EQ
 (CAR
 *EVENTS*)
+                              *CURRENT-EVENT*)
+                     (SETQ
 *EVENTS* (CDR
 *EVENTS*)))
+              (SETQ
 VALUE-P NIL)
+              (SETQ
 PRED-P NIL)
+              (GO
 LP])
+
+(PRINT-EVENT

+  [CL:LAMBDA (EVENT &OPTIONAL NOVALUES)                      (* ; "Edited  9-Mar-87 11:02 by raf")
+
+         (PROG
 ((INPUT
 (EXEC-EVENT-INPUT
 EVENT))
+                    (FILE (\GETSTREAM
 T 'OUTPUT))
+                    (POSITION
 (STRINGWIDTH
 "99/9999>" T))
+                    Y TEM EVENT#)
+                   (FRESHLINE
 FILE)
+                   (if (SETQ
 TEM (LISTGET
 (EXEC-EVENT-PROPS EVENT)
+                                            '*HISTORY*))
+                       then
+                       (DSPXPOSITION
 POSITION FILE)
+                       (CL:FORMAT
 FILE "~{~S ~}~&" TEM))
+                   (PRINT-EVENT-PROMPT
 EVENT)
+                   (DSPXPOSITION
 (MAX
 POSITION (DSPXPOSITION
 NIL FILE))
+                          T)
+                   (DSPFONT
 INPUTFONT FILE)
+               LP  [COND

+                      ((SETQ
 Y (FMEMB
 HISTSTR0 (LISTP
 INPUT)))
+                       (SETQ
 INPUT (LDIFF
 INPUT Y]
+                   [COND

+                      [(NLISTP
 INPUT)
+                       (COND

+                          ((NULL
 INPUT)
+                           (if (EXEC-EVENT-PROPS EVENT)
+                               then                          (* ; "don't do anything")
+
+                               else
+                               (PRIN1
 "<in progress>" FILE)))
+                          (T                                 (* ; "shouldn't happen??")
+
+                             (EXEC-PRIN1
 INPUT]
+                      [(CDDR
 INPUT)                      (* ; 
+                                                             "a command, just print out all elements")
+
+                       (CASE (CAR
 INPUT)
+                             (DO-EVENTS                      (* ; 
+                                                             " special generated combination event")
+
+                                    (DSPFONT
 DEFAULTFONT FILE)
+                                    (CL:FORMAT
 FILE "~A" (CAR
 INPUT))
+                                    (DSPFONT
 INPUTFONT FILE)
+                                    (for X in (CDR
 INPUT)
+                                         do
+                                         (FRESHLINE
 FILE)
+                                         (DSPXPOSITION
 POSITION FILE)
+                                         (CL:FORMAT
 FILE "   ~S" X)))
+                             (T (CL:FORMAT
 FILE "~{~S ~}~&" INPUT]
+                      [(CDR
 INPUT)                       (* ; "APPLY format")
+
+                       (EXEC-PRIN1
 (CAR
 INPUT))
+                       (COND

+                          ((NULL
 (SETQ
 TEM (CADR
 INPUT)))
+                           (PRIN1
 ")" FILE))
+                          (T (COND

+                                ((NLISTP
 TEM)
+                                 (SPACES
 1 FILE)))
+                             (EXEC-PRIN1
 TEM]
+                      (T                                     (* ; "EVAL input")
+
+                         (EXEC-PRIN1
 (CAR
 INPUT]
+                   (COND

+                      (Y (SETQ
 INPUT (CDR
 Y))
+                         (TERPRI
 FILE)
+                         (DSPXPOSITION
 POSITION FILE)
+                         (GO
 LP)))
+               LP1 [LET
 [(RNT (CL:GETF
 (EXEC-EVENT-PROPS EVENT)
+                                         '*LISPXPRINT*]
+                          (if RNT then (DSPFONT
 PRINTOUTFONT FILE)
+                              (FRESHLINE
 FILE)
+                              (MAPC
 RNT (FUNCTION
 (LAMBDA (X)
+                                                            (LISPXREPRINT
 X FILE]
+                   (COND

+                      ((NOT
 NOVALUES)
+                       (DSPFONT
 VALUEFONT FILE)
+                       (for X in (LISTGET
 (CDDDR
 EVENT)
+                                        'LISPXVALUES)
+                            do
+                            (FRESHLINE
 FILE)
+                            (DSPXPOSITION
 POSITION FILE)
+                            (EXEC-PRIN1
 X])
+
+(PRINT-EVENT-PROMPT

+  [LAMBDA (EVENT)                                            (* ; "Edited  2-Mar-87 16:47 by raf")
+
+    (LET
 [(TERM (\GETSTREAM
 T 'OUTPUT]               (* ; 
+                             "Crock because format interprets T to mean primary output, not terminal")
+
+           (FRESHLINE
 TERM)
+           (if (CL:CONSP
 (EXEC-EVENT-ID
 EVENT))
+               then
+               (DSPFONT
 PROMPTFONT TERM)
+               (DESTRUCTURING-BIND (INDEX ID . PROMPT)
+                      (EXEC-EVENT-ID
 EVENT)
+                      (IF (CL:EQUAL
 ID "")
+                          THEN
+                          (CL:FORMAT
 TERM "~D~A" INDEX PROMPT)
+                          ELSE
+                          (CL:FORMAT
 TERM "~A/~D~A" ID INDEX PROMPT)))
+               elseif LISPXHISTORY then (CL:FORMAT
 TERM "~D~A" (ENTRY#
 LISPXHISTORY EVENT)
+                                               (EXEC-EVENT-ID
 EVENT))
+               else                                          (* ; 
+                                                             "No prompt availible, use the default.")
+
+               (CL:FORMAT
 TERM "~A" XCL:*EXEC-PROMPT*])
+
+(PROCESS-EXEC-ID

+  (CL:LAMBDA (PROCESS &OPTIONAL ID)                          (* ; "Edited  5-Mar-87 17:29 by raf")
+
+         (OR
 (PROCESSPROP
 PROCESS 'ID)
+                (LET
 ((NAME (PROCESS.NAME
 PROCESS)))
+                       [PROCESSPROP
 PROCESS 'ID (OR
 ID (SETQ
 ID
+                                                                (COND

+                                                                   ((STRPOS
 "EXEC" NAME 1 NIL T)
+                                                                    (OR
 (SUBSTRING
 NAME 6 -1)
+                                                                           ""))
+                                                                   (T 
+                                                             (* ; "under some other process")
+
+                                                                      (STRING
 NAME]
+                       ID))))
+
+(SEARCH-FOR-EVENT-NUMBER

+  [LAMBDA (EVENTS HISTORY SPEC)                              (* lmm "11-Sep-86 10:53")
+    (while EVENTS do (if [LET
 [(ID
 (EXEC-EVENT-ID
 (CAR
 EVENTS]
+                                (COND

+                                   ((LISTP
 ID)
+                                    (EQL
 (CAR
 ID)
+                                           SPEC))
+                                   (T (EQL
 SPEC (ENTRY#
 HISTORY (CAR
 EVENTS]
+                         then
+                         (RETURN
 EVENTS)
+                         else
+                         (pop EVENTS])
+
+(\PICK.EVALQT

+  [LAMBDA NIL                                                (* ; "Edited 27-Feb-87 17:40 by raf")
+
+(* ;;; 
+"Replacement for \PROC.REPEATEDLYEVALQT.  Activated by the HARDRESET at the end of LOADUP.LISP")
+
+    (INPUT
 T)
+    (OUTPUT
 T)
+    (TTYDISPLAYSTREAM
 \TopLevelTtyWindow)
+    (\RESETSYSTEMSTATE
)
+    (EXEC
 :TOP-LEVEL-P T :PROFILE XCL:*PROFILE* :WINDOW (XCL::SETUP-EXEC-WINDOW
 
+                                                                   \TopLevelTtyWindow])
+
+(LISPXREPRINT

+  [LAMBDA (X FILE)                                           (* ; "Edited 19-Jan-87 16:03 by bvm:")
+                                                             (* ; 
+                              "takes an element from a *LISPXPRINT* property and prints it properly.")
+
+    [OR
 FILE (SETQ
 FILE (\GETSTREAM
 T 'OUTPUT]
+    (COND

+       ((STRINGP
 X)
+        (PRIN1
 X FILE))
+       ((NLISTP
 X)
+        (PRIN2
 X FILE))
+       ((CL:STRINGP
 (CAR
 X))
+        (CL:APPLY
 (FUNCTION
 CL:FORMAT)
+               FILE X))
+       (T (SELECTQ
 (CAR
 X)
+                ((PRINT PRIN1 PRIN2 SPACES) 
+                       (APPLY*
 (CAR
 X)
+                              (CADR
 X)
+                              FILE
+                              (CADDDR
 X)))
+                (TAB (TAB
 (CADR
 X)
+                            (CADDR
 X)
+                            FILE))
+                (TERPRI (TERPRI
 FILE))
+                (LISPXPRINTDEF0 [APPLY
 (CAR
 X)
+                                       (CONS
 (CADR
 X)
+                                              (CONS
 FILE (CDDDR
 X])
+                (APPLY
 (CAR
 X)
+                       (CONS
 (CADR
 X)
+                              (CONS
 FILE (CDDDR
 X])
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(MOVD? (QUOTE READ) (QUOTE TTYINREAD))
+
+(MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT))
+
+(SETQ BackgroundMenu)
+)
+
+(DEFMACRO CASE-EQUALP (SELECTOR &REST CASES) (LET* ((KV (CL:IF (CL:SYMBOLP SELECTOR) SELECTOR (GENSYM))) (CLAUSES (for STRING-CASE in CASES collect (COND ((FMEMB (CAR STRING-CASE) (QUOTE (T CL:OTHERWISE))) (BQUOTE (T (\,@ (CDR STRING-CASE))))) ((NOT (CL:CONSP (CAR STRING-CASE))) (BQUOTE ((STRING.EQUAL (\, KV) (QUOTE (\, (CAR STRING-CASE)))) (\,@ (CDR STRING-CASE))))) (T (BQUOTE ((OR (\,@ (CL:DO ((X (CAR STRING-CASE) (CDR X)) (Y NIL)) ((CL:ATOM X) (REVERSE Y)) (CL:PUSH (BQUOTE (STRING.EQUAL (\, KV) (QUOTE (\, (CAR X))))) Y)))) (\,@ (CDR STRING-CASE))))))))) (CL:IF (EQ KV SELECTOR) (BQUOTE (COND (\,@ CLAUSES))) (BQUOTE (LET (((\, KV) (\, SELECTOR))) (COND (\,@ CLAUSES)))))))
+
+(DEFMACRO EXEC-EVENT-PROPS (X) (BQUOTE (CDDDR (\, X))))
+
+(CL:DEFUN EXEC-PRINT (VALUE) (FRESHLINE T) (WRITE VALUE :STREAM *TERMINAL-IO* :ESCAPE T))
+
+(CL:DEFUN EXEC-FORMAT (FORMAT-STRING &REST ARGS) (AND (CL:STRINGP FORMAT-STRING) (LISPXPUT (QUOTE *LISPXPRINT*) (LIST (CONS FORMAT-STRING ARGS)) T *CURRENT-EVENT*)) (CL:APPLY (QUOTE CL:FORMAT) (\GETSTREAM T (QUOTE OUTPUT)) FORMAT-STRING ARGS))
+
+(ADDTOVAR BackgroundMenuCommands (EXEC (QUOTE (ADD-EXEC :TTY T)) "Start a new Exec using XCL:*PROFILE*" (SUBITEMS ("Xerox Common Lisp" (QUOTE (ADD-EXEC :PROFILE "XCL" :TTY T)) "Start a new Exec using XCL profile") ("Common Lisp" (QUOTE (ADD-EXEC :PROFILE "COMMON-LISP" :TTY T)) "Start a Common Lisp Exec" (SUBITEMS ("Old Common Lisp" (QUOTE (ADD-EXEC :PROFILE "LISP" :TTY T)) "Start an old Common Lisp (LISP package) Exec"))) ("Interlisp" (QUOTE (ADD-EXEC :PROFILE "INTERLISP" :TTY T)) "Start an Interlisp Exec" (SUBITEMS ("Old-Interlisp" (QUOTE (ADD-EXEC :PROFILE "OLD-INTERLISP-T" :EXEC (QUOTE EVALQT) :TTY T)) "Start an old-style LISPX window"))))))
+
+(ADDTOVAR SYSTEMINITVARS (LISPXHISTORY NIL 0 100 100) (GREETHIST))
+
+
+
+(* ;; "Exec Commands")

+
+
+(DEF-DEFINE-TYPE COMMANDS "Exec Commands")
+
+(DEFDEFINER (DEFCOMMAND (:NAME (CL:LAMBDA (WHOLE) (LET ((NAME (CL:SECOND WHOLE))) (CL:IF (CL:CONSP NAME) (CAR NAME) NAME))))) COMMANDS (NAME ARGUMENTS &ENVIRONMENT ENV &BODY BODY) (LET ((COMMAND-LEVEL (QUOTE *EXEC-COMMAND-TABLE*)) (COMMAND-TYPE :EVAL) (PREFIX "exec-")) (if (LISTP NAME) then (SETQ NAME (PROG1 (CAR NAME) (for X in (CDR NAME) do (CL:ECASE X ((:QUIET :HISTORY :INPUT :EVAL :MACRO) (SETQ COMMAND-TYPE X)) ((:DEBUGGER :BREAK) (SETQ COMMAND-LEVEL (QUOTE *DEBUGGER-COMMAND-TABLE*)) (SETQ PREFIX "break-"))))))) (LET* ((CMACRONAME (PACK* PREFIX NAME)) (STRINGNAME (STRING NAME))) (CL:MULTIPLE-VALUE-BIND (PARSED-BODY PARSED-DECLARATIONS PARSED-DOCSTRING) (PARSE-DEFMACRO ARGUMENTS (QUOTE $$MACRO-FORM) BODY NAME ENV :ENVIRONMENT (QUOTE $$MACRO-ENV)) (BQUOTE (PROGN (CL:SETF (CL:SYMBOL-FUNCTION (QUOTE (\, CMACRONAME))) (FUNCTION (CL:LAMBDA ($$MACRO-FORM $$MACRO-ENV) (\,@ PARSED-DECLARATIONS) (\, PARSED-BODY)))) (CL:SETF (CL:DOCUMENTATION (\, STRINGNAME) (QUOTE COMMANDS)) (\, PARSED-DOCSTRING)) (PUTHASH (\, STRINGNAME) (QUOTE (\, (MAKE-COMMAND-ENTRY :FUNCTION CMACRONAME :MODE COMMAND-TYPE :ARGUMENTS (\SIMPLIFY.CL.ARGLIST ARGUMENTS)))) (\, COMMAND-LEVEL))))))))
+
+(DEFCOMMAND ("?" :QUIET) (&OPTIONAL (NAME NIL NAMEP)) "Show forms of valid input. ? <name> shows name's documentation." (CL:IF NAMEP (PRINT-ALL-DOCUMENTATION NAME) (PROGN (CL:FORMAT T "~&You are typing at the Exec. Enter~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "<expression>") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto evaluate an expression~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "function(arg1 arg2 ...)") (DSPFONT DEFAULTFONT T) (CL:FORMAT T " ~20Tto apply function to the arguments given~&~%%or one of:") (FOR X ON (REVERSE *THIS-EXEC-COMMANDS*) DO (LET (COMS) (MAPHASH (CAR X) (CL:FUNCTION (CL:LAMBDA (VAL KEY) (AND (NOT (SOME (CDR X) (CL:FUNCTION (CL:LAMBDA (TAB) (GETHASH KEY TAB))))) (PUSH COMS (LIST KEY VAL)))))) (CL:MAPC (CL:FUNCTION (CL:LAMBDA (COM) (CL:FORMAT T "~&") (DSPFONT INPUTFONT T) (CL:FORMAT T "~A " (CAR COM)) (DSPFONT COMMENTFONT T) (PRINT-ARGLIST (COMMAND-ENTRY-ARGUMENTS (CADR COM))) (DSPFONT DEFAULTFONT T) (LET ((DOC (CL:DOCUMENTATION (CAR COM) (QUOTE COMMANDS)))) (CL:WHEN DOC (TAB 20 1 T) (CL:FORMAT T "~A" DOC))))) (CL:SORT COMS (CL:FUNCTION CL:STRING<) :KEY (CL:FUNCTION CAR))))))) (CL:VALUES))
+
+(DEFCOMMAND ("??" :QUIET) (&REST EVENT-SPECS) "Show events specified EVENT-SPECS (or all events)" (IF (AND EVENT-SPECS (EQ (CAR EVENT-SPECS) (QUOTE :INPUT))) THEN (PRINT-HISTORY LISPXHISTORY (CDR EVENT-SPECS) T) ELSE (PRINT-HISTORY LISPXHISTORY EVENT-SPECS)) (CL:VALUES))
+
+(DEFCOMMAND ("CONN" :EVAL) (&OPTIONAL DIRECTORY) "Change default pathname to DIRECTORY" (/CNDIR DIRECTORY))
+
+(DEFCOMMAND "DA" NIL "Returns current time & date" (DATE))
+
+(DEFCOMMAND ("DIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME" (DODIR (CONS PATHNAME (MAPCAR KEYWORDS (FUNCTION (LAMBDA (CL:KEYWORD) (IF (CL:SYMBOLP CL:KEYWORD) THEN (CL:INTERN (CL:SYMBOL-NAME CL:KEYWORD) "INTERLISP") ELSE CL:KEYWORD)))))))
+
+(DEFCOMMAND "DO-EVENTS" (&REST INPUTS &ENVIRONMENT ENV) "Execute the multiple events in INPUTS, using the environment ENV for all evaluations." (LET ((OUTER-EVENT (AND *CURRENT-EVENT* (COPY-EXEC-EVENT *CURRENT-EVENT*))) (* ; "DO-EVENT smashes *CURRENT-EVENT*, so we copy and save it.")) (CL:WHEN OUTER-EVENT (CL:SETF (EXEC-EVENT-INPUT OUTER-EVENT) (CONS (QUOTE DO-EVENTS) INPUTS)) (* ; "Each of these is fixed up below.")) (ERSETQ (CL:MAPL (CL:FUNCTION (CL:LAMBDA (INPUT) (LET ((TODO (CL:IF (EQ (CAR (LISTP (CAR INPUT))) (QUOTE EVENT)) (CDR (CAR INPUT)) (LIST (CAR INPUT)))) VALUES) (CL:WHEN ADDSPELLFLG (HISTORY-ADD-TO-SPELLING-LISTS TODO)) (SETQ VALUES (DO-EVENT TODO ENV)) (* ; "If it exists, *CURRENT-EVENT* gets smashed here.") (CL:WHEN OUTER-EVENT (* ; "If there is an outer event...") (* ;; "Fix the outer event's list of inputs with the expanded input.") (RPLACA INPUT (CAR (EXEC-EVENT-INPUT *CURRENT-EVENT*))) (CL:WHEN VALUES (* ; "If the last sub-event generated some values...") (* ;; "Add the new values to the outer event's values.") (LET ((OLD-VALUES (CL:GETF (EXEC-EVENT-PROPS OUTER-EVENT) (QUOTE LISPXVALUES)))) (CL:IF OLD-VALUES (NCONC OLD-VALUES VALUES) (CL:SETF (EXEC-EVENT-PROPS OUTER-EVENT) (LIST* (QUOTE LISPXVALUES) VALUES (EXEC-EVENT-PROPS OUTER-EVENT)))))))))) INPUTS)) (CL:WHEN *CURRENT-EVENT* (* ; "If there was a current event...") (* ; "Smash saved values back from OUTER-EVENT.") (CL:SETF (EXEC-EVENT-INPUT *CURRENT-EVENT*) (EXEC-EVENT-INPUT OUTER-EVENT)) (CL:SETF (EXEC-EVENT-ID *CURRENT-EVENT*) (EXEC-EVENT-ID OUTER-EVENT)) (CL:SETF (EXEC-EVENT-VALUE *CURRENT-EVENT*) (EXEC-EVENT-VALUE OUTER-EVENT)) (CL:SETF (EXEC-EVENT-PROPS *CURRENT-EVENT*) (EXEC-EVENT-PROPS OUTER-EVENT)))) (SETQ *CURRENT-EVENT* NIL) (* ; "Keeps the DO-EVENT which is evaluating us from setting the event's results to (the result of evaluating) the NIL we return.  This is alright since *CURRENT-EVENT* is already pointed to by the history list.") (CL:VALUES) (* ; "We've evaluated all the subforms directly with DO-EVENT so we don't return a form to EVAL."))
+
+(DEFCOMMAND ("FIX" :HISTORY) (&REST EVENT-SPEC) "Edit input for specified events" (APPLY (QUOTE FIX-FORM) (CL:MULTIPLE-VALUE-LIST (CIRCLAR-COPYER (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY))))))
+
+(DEFCOMMAND "FORGET" (&REST EVENT-SPEC) "Erase UNDO information (for specified events)." (FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY) DO (UNDOLISPX2 EVENT T) FINALLY (CL:FORMAT T "Forgotten.~&")) (CL:VALUES))
+
+(DEFCOMMAND "NAME" (COMMAND-NAME &OPTIONAL ARGUMENT-LIST &REST EVENT-SPEC) "NAME command-name [argument-list] [event-spec] defines new command containing the event." (CL:UNLESS (LISTP ARGUMENT-LIST) (CL:PUSH ARGUMENT-LIST EVENT-SPEC) (SETQ ARGUMENT-LIST NIL)) (LET ((EVENTS (FIND-HISTORY-EVENTS EVENT-SPEC LISPXHISTORY)) (ARGNAMES (FOR I FROM 1 AS X IN ARGUMENT-LIST COLLECT (PACK* (QUOTE ARG) I)))) (CL:EVAL (BQUOTE (DEFCOMMAND ((\, COMMAND-NAME) :HISTORY) (\, ARGNAMES) (SUBPAIR (QUOTE (\, ARGNAMES)) (LIST (\,@ ARGNAMES)) (QUOTE (\, (SUBPAIR ARGUMENT-LIST ARGNAMES (EVENTS-INPUT EVENTS) T)))))))))
+
+(DEFCOMMAND ("NDIR" :EVAL) (&OPTIONAL PATHNAME &REST KEYWORDS) "Show directory listing for PATHNAME in abbreviated format" (DODIR (CONS PATHNAME KEYWORDS) (QUOTE (P COLUMNS 20)) (QUOTE *) ""))
+
+(DEFCOMMAND "PL" (CL:SYMBOL) "Show property list of SYMBOL" (PRINTPROPS CL:SYMBOL) (CL:VALUES))
+
+(DEFCOMMAND ("REDO" :HISTORY) (&REST EVENT-SPEC) "Re-execute specified event(s)" (EVENTS-INPUT (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY)))
+
+(DEFCOMMAND ("REMEMBER" :EVAL) (&REST EVENT-SPEC) "Tell Manager to remember type-in from specified event(s)" (MARKASCHANGED (GETEXPRESSIONFROMEVENTSPEC EVENT-SPEC) (QUOTE EXPRESSIONS)))
+
+(DEFCOMMAND ("SHH" :QUIET) (&REST LINE) "Execute LINE without history processing" (EVAL-INPUT LINE))
+
+(DEFCOMMAND "UNDO" (&REST EVENT-SPEC) "Undo side effects associated with the specified event (or last undoable one)" (FOR EVENT IN (FIND-HISTORY-EVENTS (OR EVENT-SPEC (QUOTE (-1))) LISPXHISTORY) DO (LET ((INPUT (CAR (EXEC-EVENT-INPUT EVENT))) (RESULT (UNDOLISPX2 EVENT))) (CL:IF (LISTP INPUT) (SETQ INPUT (CAR INPUT))) (COND ((NULL RESULT) (CL:FORMAT T "No undo info saved for ~A.~&" INPUT)) ((EQ RESULT (QUOTE already)) (CL:FORMAT T "~A already undone.~&" INPUT)) (T (CL:FORMAT T "~A undone.~&" INPUT))))) (CL:VALUES))
+
+(DEFCOMMAND ("USE" :HISTORY) (&REST LINE) "USE <new> [FOR <old>] [IN <event-spec>]" (* ;; "this code stolen from LISPXUSE in HIST and edited. The structure is still pretty incomprehensible") (PROG (EVENT-SPECS EXPR ARGS VARS (STATE (QUOTE VARS)) LST TEM USE-ARGS GENLST) LP (COND ((OR (NULL LST) (NULL (CDR LINE)) (NULL (CASE-EQUALP (CAR LINE) (* ; "look for one of the special keywords") (FOR (COND ((EQ STATE (QUOTE VARS)) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE (QUOTE ARGS)) (SETQ LST NIL) T))) (AND (COND ((EQ STATE (QUOTE EXPR)) NIL) (T (COND ((EQ STATE (QUOTE ARGS)) (SETQ ARGS (NCONC1 ARGS LST))) ((EQ STATE (QUOTE VARS)) (* ; "E.g. user types USE A AND B following previous USE command.") (SETQ VARS (NCONC1 VARS LST)))) (SETQ STATE (QUOTE VARS)) (SETQ LST NIL) T))) (IN (COND ((AND (EQ STATE (QUOTE VARS)) (NULL ARGS)) (SETQ VARS (NCONC1 VARS LST)) (SETQ TEM (APPEND LST TEM)) (SETQ STATE (QUOTE EXPR)) (SETQ LST NIL) T) ((EQ STATE (QUOTE ARGS)) (SETQ ARGS (NCONC1 ARGS LST)) (SETQ STATE (QUOTE EXPR)) (SETQ LST NIL) T)))))) (SETQ LST (NCONC1 LST (COND (NIL (MEMBER (CAR LINE) TEM) (* ;; "This enables USE A B FOR B A, USE A FOR B AND B FOR A, or USE A FOR B AND B C FOR A") (LET ((TEMP (CONCAT "temp string"))) (CL:PUSH (CONS (CAR LINE) TEMP) GENLST) TEMP)) (T (CAR LINE))))))) (COND ((SETQ LINE (CDR LINE)) (GO LP))) (CL:ECASE STATE (VARS (SETQ VARS (NCONC1 VARS LST))) (ARGS (SETQ ARGS (NCONC1 ARGS LST))) (EXPR (SETQ EXPR LST))) (CL:WHEN (NULL EXPR) (CL:IF ARGS (SETQ EXPR (LIST (QUOTE F) (CAAR ARGS))) (SETQ EXPR (QUOTE (-1))))) (* ;; "EXPR specifies expressions to be substituted into, e.g. USE FOO FOR FIE IN FUM or USE FOO FOR FIE. In the latter case, searches for FIE. The F is added to avoid confusion with event numbers, etc.") (* ;; "") (SETQ EXPR (MAPCAR (FIND-HISTORY-EVENTS EXPR LISPXHISTORY) (FUNCTION EXEC-EVENT-INPUT))) (* ; "EXPR is now a list of event inputs") (* ;; "at this point, VARS is a list of list of old things, the extra list corresponding to the clauses of an AND, e.g. ") (* ;; "USE A B FOR C AND D E FOR F would have ") (* ;; "((A B) (D E)) for VARS and") (* ;; "((C) (F)) for ARGS.") (IF (NULL ARGS) THEN (SETQ EXPR (FOR X IN EXPR JOIN (FOR VAR IN VARS COLLECT (IF (CL:CONSP (CAR X)) THEN (CONS (CONS (CAR VAR) (CDAR X)) (CDR X)) ELSE (CONS (CAR VAR) (CDR X)))))) ELSE (WHILE ARGS DO (SETQ EXPR (LISPXUSE1 (POP VARS) (POP ARGS) EXPR)) FINALLY (COND (VARS (ERROR (QUOTE "use what??") "" T))) (MAPC GENLST (FUNCTION (LAMBDA (X) (LISPXSUBST (CAR X) (CDR X) EXPR T)))) (* ;; "samples:") (* ;; " USE A B C D FOR X Y means substitute A for X and B for Y and then do it again with C for X and D for Y") (* ;; " Equivalent to USE A C FOR X AND B D FOR Y") (* ;; " USE A B C FOR D AND X Y Z FOR W means 3 operations:") (* ;; "  A for D and X for W in the first") (* ;; "  B for D and Y for W in the second") (* ;; " C for D and Z for W in the third") (* ;; "USE A B C FOR D AND X FOR Y means 3 operations:") (* ;; " A for D and X for Y in first") (* ;; " B for D and X for Y in second, etc.") (* ;; "USE A B C FOR D AND X Y FOR Z causes error") (* ;; "") (* ;; " USE A B FOR B A will work correctly, but USE A FOR B AND B FOR A will result in all B's being changed to A's.") (* ;; "") (* ;; "The general rule is substitution proceeds from left to right with each %%'AND' handled separately. Whenever the number of variables exceeds the number of expressions available, the expressions multiply."))) (RETURN (COND ((CDR EXPR) (CONS (QUOTE DO-EVENTS) (for X in EXPR collect (COND ((CDR X) (CONS (QUOTE EVENT) X)) (T (CAR X)))))) (T (CAR EXPR))))))
+
+(DEFCOMMAND "PP" (&OPTIONAL (NAME LASTWORD) &REST TYPES) "Show TYPES (or any) definition for NAME" (CL:BLOCK NIL (* ;; "returned from if no definitions found") (for TYPE in (OR TYPES (TYPESOF NAME NIL NIL (QUOTE ?) (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE (QUOTE EDITDEF)) (QUOTE NILL))))) (TYPESOF (SETQ NAME (OR (FIXSPELL NAME NIL USERWORDS NIL NIL (FUNCTION (LAMBDA (WORD) (TYPESOF WORD NIL (QUOTE (FIELDS FILES)) (QUOTE CURRENT)))) NIL NIL NIL (QUOTE MUSTAPPROVE)) (PROGN (CL:FORMAT *TERMINAL-IO* "No definitions found for ~S." NAME) (RETURN NIL)))) NIL NIL (QUOTE ?) (FUNCTION (LAMBDA (TYPE) (NEQ (GET TYPE (QUOTE EDITDEF)) (QUOTE NILL)))))) do (CL:FORMAT *TERMINAL-IO* "~A definition for ~S:~%%" TYPE NAME) (SHOWDEF NAME TYPE))) (CL:VALUES))
+
+
+
+(* ;; "Arrange to use the correct compiler")

+
+
+(PUTPROPS CMLEXEC FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA DIR)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA)
+)
+(PRETTYCOMPRINT CMLEXECCOMS)
+
+(RPAQQ CMLEXECCOMS ((FILES CMLUNDO PROFILE) (XCL:PROFILES "EXEC") (STRUCTURES COMMAND-ENTRY EXEC-EVENT-ID EXEC-EVENT HISTORY) (* ; "These are public except for command-entry.") (FUNCTIONS XCL::EXEC-CLOSEFN XCL::EXEC-SHRINKFN XCL::SETUP-EXEC-WINDOW XCL::EXEC-TITLE-FUNCTION FIX-FORM XCL::GET-PROCESS-PROFILE XCL::SAVE-CURRENT-EXEC-PROFILE XCL::SETF-GET-PROCESS-PROFILE XCL:SET-EXEC-TYPE XCL:SET-DEFAULT-EXEC-TYPE XCL::ENTER-EXEC-FUNCTION) (SETFS XCL::GET-PROCESS-PROFILE) (FUNCTIONS DO-EVENT EXEC EXEC-EVAL PRINT-ALL-DOCUMENTATION PRINT-DOCUMENTATION VALUE-OF ADD-EXEC EXEC-READ-LINE EXEC-EVENT-ID-PROMPT FIND-EXEC-COMMAND) (FUNCTIONS CIRCLAR-COPYER) (FNS COPY-CIRCLE) (* ; "CIRCLAR-COPYER and COPY-CIRCLE are the solution for AR#11172") (FNS EXEC-READ DIR) (VARIABLES *PER-EXEC-VARIABLES* CL:* CL:** CL:*** + CL:++ CL:+++ - / CL:// CL:/// *CURRENT-EVENT* *EXEC-ID* XCL:*EXEC-PROMPT* XCL:*EVAL-FUNCTION* *NOT-YET-EVALUATED* *THIS-EXEC-COMMANDS* *EXEC-COMMAND-TABLE* *DEBUGGER-COMMAND-TABLE* *CURRENT-EXEC-TYPE* *EXEC-MAKE-UNDOABLE-P*) (VARIABLES *EDIT-INPUT-WITH-TTYIN*) (FNS DO-APPLY-EVENT DO-HISTORY-SEARCH EVAL-INPUT EVENTS-INPUT EXEC-PRIN1 EXEC-VALUE-OF GET-NEXT-HISTORY-EVENT HISTORY-ADD-TO-SPELLING-LISTS HISTORY-NTH PRINT-HISTORY FIND-HISTORY-EVENTS PRINT-EVENT PRINT-EVENT-PROMPT PROCESS-EXEC-ID SEARCH-FOR-EVENT-NUMBER \PICK.EVALQT LISPXREPRINT) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE READ) (QUOTE TTYINREAD)) (MOVD (QUOTE \PICK.EVALQT) (QUOTE \PROC.REPEATEDLYEVALQT)) (SETQ BackgroundMenu))) (FUNCTIONS CASE-EQUALP EXEC-EVENT-PROPS EXEC-PRINT EXEC-FORMAT) (ALISTS (BackgroundMenuCommands EXEC)) (ALISTS (SYSTEMINITVARS LISPXHISTORY GREETHIST)) (* ;; "Exec Commands") (DEFINE-TYPES COMMANDS) (FUNCTIONS DEFCOMMAND) (COMMANDS "?" "??" "CONN" "DA" "DIR" "DO-EVENTS" "FIX" "FORGET" "NAME" "NDIR" "PL" "REDO" "REMEMBER" "SHH" "UNDO" "USE" "PP") (* ;; "Arrange to use the correct compiler") (PROP FILETYPE CMLEXEC) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA PROCESS-EXEC-ID PRINT-EVENT PRINT-HISTORY EXEC-PRIN1 EVENTS-INPUT EVAL-INPUT EXEC-READ)))))
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA PROCESS-EXEC-ID PRINT-EVENT PRINT-HISTORY EXEC-PRIN1 EVENTS-INPUT EVAL-INPUT EXEC-READ)
+)
+(PUTPROPS CMLEXEC COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (20107 21061 (COPY-CIRCLE 20117 . 21059)) (21139 24444 (EXEC-READ 21149 . 24310) (DIR 
+24312 . 24442)) (26450 53584 (DO-APPLY-EVENT 26460 . 27022) (DO-HISTORY-SEARCH 27024 . 28481) (
+EVAL-INPUT 28483 . 33912) (EVENTS-INPUT 33914 . 35292) (EXEC-PRIN1 35294 . 35470) (EXEC-VALUE-OF 35472
+ . 35811) (GET-NEXT-HISTORY-EVENT 35813 . 37308) (HISTORY-ADD-TO-SPELLING-LISTS 37310 . 38298) (
+HISTORY-NTH 38300 . 39050) (PRINT-HISTORY 39052 . 39673) (FIND-HISTORY-EVENTS 39675 . 44736) (
+PRINT-EVENT 44738 . 48959) (PRINT-EVENT-PROMPT 48961 . 50165) (PROCESS-EXEC-ID 50167 . 51112) (
+SEARCH-FOR-EVENT-NUMBER 51114 . 51742) (\PICK.EVALQT 51744 . 52255) (LISPXREPRINT 52257 . 53582)))))
+STOP

CLTL2/CMLFILESYS

@@ -0,0 +1,156 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "18-Oct-93 11:06:53" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;2"
 8169   
+
+      |previous| |date:| " 3-Aug-91 11:23:10" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFILESYS.;1"
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLFILESYSCOMS)
+
+(RPAQQ CMLFILESYSCOMS
 ((FUNCTIONS LISP:DIRECTORY LISP:FILE-AUTHOR LISP:FILE-LENGTH 
+                                  LISP:FILE-POSITION LISP:USER-HOMEDIR-PATHNAME LISP:FILE-WRITE-DATE)
+                           (FUNCTIONS LISP:PROBE-FILE LISP:RENAME-FILE LISP:DELETE-FILE)
+                           (PROP FILETYPE CMLFILESYS)))
+
+(LISP:DEFUN LISP:DIRECTORY
 (PATHNAME)
+   (LISP:WHEN (LISP::LOGICAL-PATHNAME-P PATHNAME)
+       (LISP:SETQ PATHNAME (LISP:TRANSLATE-LOGICAL-PATHNAME PATHNAME)))
+   (LET (GENERATOR FILE)
+        (DECLARE
 (LISP:SPECIAL GENERATOR))
+        (RESETLST
+            (|if|
 (EQL \\MACHINETYPE \\MAIKO)
+                |then|
 (RESETSAVE NIL '(AND RESETSTATE (\\UFS.ABORT.CL-DIRECTORY))))
+            (LISP:SETQ GENERATOR (\\GENERATEFILES (DIRECTORY.FILL.PATTERN (LISP:NAMESTRING PATHNAME))
+                                        NIL
+                                        '(SORT RESETLST)))
+            (|while|
 (SETQ FILE (\\GENERATENEXTFILE GENERATOR)) |collect|
 (PATHNAME FILE)))))
+
+(LISP:DEFUN LISP:FILE-AUTHOR
 (LISP::FILE)
+
+(* |;;;| "Returns author of file as string, or NIL if it cannot be determined.  FILE is a filename or stream.")

+
+   (LET ((LISP::AUTHOR (GETFILEINFO LISP::FILE 'AUTHOR)))
+        (LISP:IF LISP::AUTHOR
+            (COERCE LISP::AUTHOR 'LISP:SIMPLE-STRING)
+            NIL)))
+
+(LISP:DEFUN LISP:FILE-LENGTH
 (FILE-STREAM)
+   (|if|
 (AND (STREAMP FILE-STREAM)
+                  (OPENP FILE-STREAM))
+       |then|
 (GETEOFPTR FILE-STREAM)))
+
+(LISP:DEFUN LISP:FILE-POSITION
 (LISP::FILE-STREAM &OPTIONAL (LISP:POSITION NIL LISP::POSITIONP)
+                                          )
+   (LISP:UNLESS (STREAMP LISP::FILE-STREAM)
+          (\\ILLEGAL.ARG LISP::FILE-STREAM))
+   (LISP:IF LISP::POSITIONP
+       (LISP:IF (RANDACCESSP LISP::FILE-STREAM)
+           (PROGN (SETFILEPTR LISP::FILE-STREAM (CASE LISP:POSITION
+                                                    (:START 0)
+                                                    (:END (GETEOFPTR LISP::FILE-STREAM))
+                                                    (T LISP:POSITION)))
+                  T)
+           NIL)
+       (GETFILEPTR LISP::FILE-STREAM)))
+
+(LISP:DEFUN LISP:USER-HOMEDIR-PATHNAME
 (&OPTIONAL HOST)
+   (DECLARE
 (GLOBALVARS LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))
+   (LISP:IF (MACHINETYPE 'MAIKO)
+       (LISP:IF (AND HOST (LISP:STRING-NOT-EQUAL (STRING HOST)
+                                 (UNIX-GETPARM "HOSTNAME")))
+           NIL
+           (LISP:MAKE-PATHNAME :HOST :DSK :DIRECTORY (UNPACKFILENAME.STRING (UNIX-GETENV "HOME")
+                                                            'DIRECTORY
+                                                            'RETURN)))
+       (PATHNAME (OR LOGINHOST/DIR *DEFAULT-PATHNAME-DEFAULTS*))))
+
+(LISP:DEFUN LISP:FILE-WRITE-DATE
 (FILE)
+
+   (* |;;| "Return file's creation date, or NIL if it doesn't exist.")

+
+   (* |;;| "N.B. date is returned in Common Lisp Universal Time, not Interlisp-D internal time")

+
+   (LET ((TN (LISP:PROBE-FILE
 FILE)))
+        (LISP:WHEN TN
+            (%CONVERT-INTERNAL-TIME-TO-CLUT (GETFILEINFO TN 'ICREATIONDATE)))))
+
+(LISP:DEFUN LISP:PROBE-FILE
 (FILE)
+
+(* |;;;| "Return a pathname which is the truename of the file if it exists, NIL otherwise.  Returns NIL for non-file args.")

+
+   (LISP:TYPECASE FILE
+       (STREAM (IF
 (OPENP FILE)
+                   THEN
 (PATHNAME (FETCH
 (STREAM FULLNAME) OF
 FILE))
+                 ELSE
 (LET ((NAMESTRING-IF-EXISTS (INFILEP (FETCH
 (STREAM FULLNAME)
+                                                                  OF
 FILE))))
+                               (AND NAMESTRING-IF-EXISTS (PATHNAME NAMESTRING-IF-EXISTS)))))
+       (LISP:LOGICAL-PATHNAME (LISP:PROBE-FILE
 (LISP:TRANSLATE-LOGICAL-PATHNAME FILE)))
+       (T (LET ((INFILEP (\\GETFILENAME FILE 'OLD)))
+               (IF
 INFILEP
+                   THEN
 (PATHNAME INFILEP)
+                 ELSE
 NIL)))))
+
+(LISP:DEFUN LISP:RENAME-FILE
 (LISP::FILE LISP::NEW-NAME)
+
+(* |;;;| "Give FILE the new name NEW-NAME.  If FILE is an open stream, error.  Otherwise, do the rename.  If successful, return three values: the new name, truename of original file, truename of new file.")

+
+(* |;;;| "NEW MESSINESS resulting from acceptance of logical-pathnames: the CLtL2 spec for the first argument, (MERGE-PATHNAMES NEW-NAME FILE), makes no sense if either of FILE or NEW-NAME is a logical-pathname, since the logical-to-normal translation process can do arbitrary weird stuff.  Therefore, if either argument is a logical-pathname, we punt and return the new truename as the first argument.")

+
+   (LET* ((LISP::LOGICAL-USED? NIL)
+          (LISP::OLD-PATHNAME (LISP:IF (LISP::LOGICAL-PATHNAME-P LISP::FILE)
+                                  (PROGN (LISP:SETQ LISP::LOGICAL-USED? T)
+                                         (LISP:TRANSLATE-LOGICAL-PATHNAME LISP::FILE))
+                                  (PATHNAME LISP::FILE)))
+          (LISP::NEW-FULLNAME))
+         (LISP:WHEN (LISP::LOGICAL-PATHNAME-P LISP::NEW-NAME)
+             (LISP:SETQ LISP::LOGICAL-USED? T LISP::NEW-NAME (LISP:TRANSLATE-LOGICAL-PATHNAME 
+                                                                    LISP::NEW-NAME)))
+         (IF
 (STREAMP LISP::FILE)
+             THEN
 (IF
 (OPENP LISP::FILE)
+                          THEN
 (LISP:ERROR "Renaming open streams is not supported: ~S" 
+                                          LISP::FILE)
+                        ELSE
 (LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:SETQ
+                                                                            LISP::FILE
+                                                                            (FETCH
 (STREAM 
+                                                                                             FULLNAME
+                                                                                              )
+                                                                               OF
 LISP::FILE))
+                                                                      LISP::NEW-NAME)))
+           ELSE
 
+
+                 (* |;;| "IL:RENAMEFILE will accept logical-pathnames")

+
+                 (LISP:SETQ LISP::NEW-FULLNAME (RENAMEFILE (LISP:IF LISP::LOGICAL-USED?
+                                                               LISP::OLD-PATHNAME
+                                                               LISP::FILE)
+                                                      LISP::NEW-NAME)))
+         (IF
 LISP::NEW-FULLNAME
+             THEN
 (LISP:VALUES (LISP:IF LISP::LOGICAL-USED?
+                                       (PATHNAME LISP::NEW-FULLNAME)
+                                       (LISP:MERGE-PATHNAMES LISP::NEW-NAME LISP::FILE))
+                             LISP::OLD-PATHNAME
+                             (PATHNAME LISP::NEW-FULLNAME))
+           ELSE
 (LISP:ERROR "Rename failed"))))
+
+(LISP:DEFUN LISP:DELETE-FILE
 (FILE)
+   
+         (* * "Delete the specified file.")

+
+   (LET ((TN (LISP:PROBE-FILE
 FILE)))
+        (LISP:WHEN (STREAMP FILE)
+               (LISP:CLOSE FILE :ABORT T))
+        (LISP:IF TN
+            (LET ((NS (INTERLISP-NAMESTRING TN)))
+                 (LISP:UNLESS (DELFILE NS)
+                        (LISP:ERROR "Could not delete the file ~S" FILE)))
+            (LISP:UNLESS (STREAMP FILE)
+                   (LISP:ERROR "File to be deleted does not exist: ~S" FILE))))
+   T)
+
+(PUTPROPS CMLFILESYS
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLFILESYS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLFLOAT

@@ -0,0 +1,385 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+
(IL:FILECREATED "24-Mar-92 13:57:12" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLFLOAT.;2|
 42560  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLFLOATCOMS) (IL:VARIABLES CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT)
+
+      IL:|previous| IL:|date:| "16-May-90 13:16:23" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLFLOAT.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLFLOATCOMS)
+
+(IL:RPAQQ IL:CMLFLOATCOMS ((IL:* IL:|;;;| "CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions.  Section 12.10, implementation parameters. ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:* IL:\; "To generate unboxed opcodes") (IL:FILES IL:UNBOXEDOPS) (IL:* IL:\; "To get constants from llfloat ") (IL:FILES (IL:LOADCOMP) IL:LLFLOAT)) (IL:COMS (IL:* IL:|;;| "Section 12.10, implementation parameters.  ") (IL:* IL:|;;| "%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects.") (IL:* IL:|;;| "Reading and printing of floats has since been fixed, so LISP::%FLOAT is not technically necessary anymore - JRB") (IL:FUNCTIONS %FLOAT) (IL:VARIABLES MOST-POSITIVE-FIXNUM MOST-NEGATIVE-FIXNUM) (IL:VARIABLES MOST-POSITIVE-SINGLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT) (IL:VARIABLES MOST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SHORT-FLOAT LEAST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SHORT-FLOAT MOST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-DOUBLE-FLOAT MOST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-LONG-FLOAT LEAST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-LONG-FLOAT) (IL:* IL:|;;| "CLtL2 implementation parameters ") (IL:VARIABLES CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT) (IL:* IL:|;;| "EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-EPSILON) (IL:VARIABLES SHORT-FLOAT-EPSILON DOUBLE-FLOAT-EPSILON LONG-FLOAT-EPSILON) (IL:* IL:|;;| "NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) ") (IL:VARIABLES SINGLE-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES SHORT-FLOAT-NEGATIVE-EPSILON DOUBLE-FLOAT-NEGATIVE-EPSILON LONG-FLOAT-NEGATIVE-EPSILON) (IL:VARIABLES PI)) (IL:COMS (IL:* IL:|;;| "Internal constants") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %E %2PI %PI %2PI/3 %PI/2 %-PI/2 %PI/3 %PI/4 %-PI/4 %PI/6 %2/PI))) (IL:COMS (IL:* IL:|;;| "Utility macros") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FUNCTIONS %FLOAT-UNBOX %GET-TABLE-ENTRY %POLYEVAL %UFTRUNCATE %UMAKE-FLOAT))) (IL:* IL:|;;| " Unpack floating point functions") (IL:COMS (IL:FUNCTIONS DECODE-FLOAT SCALE-FLOAT FLOAT-RADIX FLOAT-SIGN FLOAT-DIGITS FLOAT-PRECISION INTEGER-DECODE-FLOAT)) (IL:COMS (IL:* IL:|;;| "Exp  (e to the power x)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG-BASE2-E)) (IL:VARIABLES %EXP-POLY %EXP-TABLE)) (IL:FUNCTIONS %EXP-FLOAT) (IL:FUNCTIONS EXP)) (IL:COMS (IL:* IL:|;;| "Expt (x to the power y)") (IL:FUNCTIONS %EXPT-INTEGER %EXPT-FLOAT-INTEGER) (IL:FUNCTIONS EXPT)) (IL:COMS (IL:* IL:|;;| "Log (log base e)") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %LOG2 %SQRT2)) (IL:VARIABLES %LOG-PPOLY %LOG-QPOLY)) (IL:FUNCTIONS %LOG-FLOAT) (IL:FUNCTIONS LOG)) (IL:COMS (IL:* IL:|;;| "Sqrt") (IL:FUNCTIONS %SQRT-FLOAT %SQRT-COMPLEX) (IL:FUNCTIONS SQRT)) (IL:COMS (IL:* IL:|;;| "Sin and Cos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SIN-EPSILON)) (IL:VARIABLES %SIN-PPOLY %SIN-QPOLY)) (IL:FUNCTIONS %SIN-FLOAT) (IL:FUNCTIONS SIN COS)) (IL:COMS (IL:* IL:|;;| "Tan") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %TAN-EPSILON)) (IL:VARIABLES %TAN-PPOLY %TAN-QPOLY)) (IL:FUNCTIONS %TAN-FLOAT) (IL:FUNCTIONS TAN)) (IL:COMS (IL:* IL:|;;| "Asin and Acos") (IL:COMS (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %ASIN-EPSILON)) (IL:VARIABLES %ASIN-PPOLY %ASIN-QPOLY)) (IL:FUNCTIONS %ASIN-FLOAT) (IL:FUNCTIONS ASIN ACOS)) (IL:COMS (IL:* IL:|;;| "Atan ") (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES %SQRT3 %2-SQRT3 %INV-2-SQRT3)) (IL:FUNCTIONS %ATAN-FLOAT) (IL:FUNCTIONS ATAN)) (IL:COMS (IL:* IL:|;;| "Cis (exp (i x))") (IL:FUNCTIONS CIS)) (IL:COMS (IL:* IL:|;;| "Sinh, Cosh Tanh") (IL:FUNCTIONS SINH COSH TANH)) (IL:COMS (IL:* IL:|;;| "Asinh Acosh Atanh") (IL:FUNCTIONS ASINH ACOSH ATANH)) (IL:COMS (IL:* IL:|;;| "rational and rationalize ") (IL:FUNCTIONS %RATIONAL-FLOAT %RATIONALIZE-FLOAT)) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:LOCALVARS . T)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:CMLFLOAT)))
+
+
+
+(IL:* IL:|;;;| 
+"CMLFLOAT -- Covering sections 12.5-12.5.3 irrational, transcendental, exponential, logarithmic, trigonometric, and hyperbolic functions.  Section 12.10, implementation parameters. "
+)

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(IL:FILESLOAD IL:UNBOXEDOPS)
+
+
+(IL:FILESLOAD (IL:LOADCOMP) IL:LLFLOAT)
+)
+
+
+
+(IL:* IL:|;;| "Section 12.10, implementation parameters.  ")

+
+
+
+
+(IL:* IL:|;;| 
+"%FLOAT allows us to recreate FLOATPs in a way that is independent of the ordinairy reading and printing FLOATPs to files which involves loss of the last couple bits of accuracy due to rounding effects."
+)

+
+
+
+
+(IL:* IL:|;;| 
+"Reading and printing of floats has since been fixed, so LISP::%FLOAT is not technically necessary anymore - JRB"
+)

+
+
+(DEFUN %FLOAT (HIWORD LOWORD) (IL:\\FLOATBOX (IL:\\VAG2 HIWORD LOWORD)))
+
+(DEFCONSTANT MOST-POSITIVE-FIXNUM 65535)
+
+(DEFCONSTANT MOST-NEGATIVE-FIXNUM -65536)
+
+(DEFCONSTANT MOST-POSITIVE-SINGLE-FLOAT (%FLOAT 32639 65535))
+
+(DEFCONSTANT LEAST-POSITIVE-SINGLE-FLOAT (%FLOAT 0 1))
+
+(DEFCONSTANT LEAST-NEGATIVE-SINGLE-FLOAT (%FLOAT 32768 1))
+
+(DEFCONSTANT MOST-NEGATIVE-SINGLE-FLOAT (%FLOAT 65407 65535))
+
+(DEFCONSTANT MOST-POSITIVE-SHORT-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-SHORT-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-SHORT-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-SHORT-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-POSITIVE-DOUBLE-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-DOUBLE-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-DOUBLE-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-DOUBLE-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-POSITIVE-LONG-FLOAT MOST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-POSITIVE-LONG-FLOAT LEAST-POSITIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT LEAST-NEGATIVE-LONG-FLOAT LEAST-NEGATIVE-SINGLE-FLOAT)
+
+(DEFCONSTANT MOST-NEGATIVE-LONG-FLOAT MOST-NEGATIVE-SINGLE-FLOAT)
+
+
+
+(IL:* IL:|;;| "CLtL2 implementation parameters ")

+
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT (%FLOAT 128 0) "Documentation string")
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT (%FLOAT 32896 0))
+
+(DEFCONSTANT CL:LEAST-POSITIVE-NORMALIZED-LONG-FLOAT (%FLOAT 128 0))
+
+(DEFCONSTANT CL:LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT (%FLOAT 32896 0))
+
+
+
+(IL:* IL:|;;| 
+"EPSILON is the smallest positive floating point number such that (NOT (= (FLOAT 1 EPSILON) (+ (FLOAT 1 EPSILON) EPSILON))) "
+)

+
+
+(DEFCONSTANT SINGLE-FLOAT-EPSILON (%FLOAT (ASH 103 7) 1))
+
+(DEFCONSTANT SHORT-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+(DEFCONSTANT DOUBLE-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+(DEFCONSTANT LONG-FLOAT-EPSILON SINGLE-FLOAT-EPSILON)
+
+
+
+(IL:* IL:|;;| 
+"NEGATIVE-EPSILON is the smallest negative floating point number such that (NOT (= (FLOAT 1 NEGATIVE-EPSILON) (- (FLOAT 1 NEGATIVE-EPSILON) NEGATIVE-EPSILON))) "
+)

+
+
+(DEFCONSTANT SINGLE-FLOAT-NEGATIVE-EPSILON (%FLOAT 13184 0))
+
+(DEFCONSTANT SHORT-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT DOUBLE-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT LONG-FLOAT-NEGATIVE-EPSILON SINGLE-FLOAT-NEGATIVE-EPSILON)
+
+(DEFCONSTANT PI (%FLOAT 16457 4059))
+
+
+
+(IL:* IL:|;;| "Internal constants")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %E (%FLOAT 16429 63572))
+
+(DEFCONSTANT %2PI (%FLOAT 16585 4059))
+
+(DEFCONSTANT %PI (%FLOAT 16457 4059))
+
+(DEFCONSTANT %2PI/3 (%FLOAT 16390 2706))
+
+(DEFCONSTANT %PI/2 (%FLOAT 16329 4059))
+
+(DEFCONSTANT %-PI/2 (%FLOAT 49097 4059))
+
+(DEFCONSTANT %PI/3 (%FLOAT 16262 2706))
+
+(DEFCONSTANT %PI/4 (%FLOAT 16201 4059))
+
+(DEFCONSTANT %-PI/4 (%FLOAT 48969 4059))
+
+(DEFCONSTANT %PI/6 (%FLOAT 16134 2706))
+
+(DEFCONSTANT %2/PI (%FLOAT 16162 63875))
+)
+
+
+
+(IL:* IL:|;;| "Utility macros")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFMACRO %FLOAT-UNBOX (FLOAT SIGN EXP HI LO &OPTIONAL DONTSHIFT) (IL:* IL:|;;| "If dontshift is T -- the floatp fields are simply unpacked (with the hiddenbit restored -- and exp set to 1 for denormalized numbers). If dontshift is NIL -- exp, hi and lo are fiddled so the high bit of hi is on.") (IL:BQUOTE (LET ((FLONUM (FLOAT (IL:\\\, FLOAT)))) (SETQ (IL:\\\, SIGN) (IL:|fetch| (IL:FLOATP IL:SIGNBIT) IL:|of| FLONUM)) (SETQ (IL:\\\, EXP) (IL:|fetch| (IL:FLOATP IL:EXPONENT) IL:|of| FLONUM)) (SETQ (IL:\\\, HI) (IL:|fetch| (IL:FLOATP IL:HIFRACTION) IL:|of| FLONUM)) (SETQ (IL:\\\, LO) (IL:|fetch| (IL:FLOATP IL:LOFRACTION) IL:|of| FLONUM)) (IF (EQ (IL:\\\, EXP) IL:\\MAX.EXPONENT) (IL:* IL:\; "might want to check for NaN's here if EXP = \\MAX.EXPONENT") (ERROR "Not a number: ~s" FLONUM)) (IF (EQ 0 (IL:\\\, EXP)) (WHEN (NOT (AND (EQ 0 (IL:\\\, HI)) (EQ 0 (IL:\\\, LO)))) (IL:* IL:\; "Denormalized number") (SETQ (IL:\\\, EXP) 1) (IL:\\\,@ (IF (NULL DONTSHIFT) (IL:BQUOTE ((LOOP (IF (NOT (EQ 0 (LOGAND (IL:\\\, HI) IL:\\HIDDENBIT))) (RETURN NIL)) (IL:.LLSH1. (IL:\\\, HI) (IL:\\\, LO)) (SETQ (IL:\\\, EXP) (1- (IL:\\\, EXP))))))))) (IL:* IL:\; " Restore the hidden bit") (SETQ (IL:\\\, HI) (+ (IL:\\\, HI) IL:\\HIDDENBIT))) (IL:\\\,@ (IF (NULL DONTSHIFT) (IL:BQUOTE ((IL:.LLSH8. (IL:\\\, HI) (IL:\\\, LO)))))) NIL)))
+
+(DEFMACRO %GET-TABLE-ENTRY (ARRAY INDEX) (IL:BQUOTE (IL:\\GETBASEFLOATP (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| (IL:\\\, ARRAY)) (IL:LLSH (IL:\\\, INDEX) 1))))
+
+(DEFMACRO %POLYEVAL (X COEFFS DEGREE) (IL:BQUOTE (IL:\\FLOATBOX ((IL:OPCODES IL:UBFLOAT3 0) (IL:\\FLOATUNBOX (IL:\\\, X)) (IL:|fetch| (IL:ONED-ARRAY IL:BASE) IL:|of| (IL:\\\, COEFFS)) (IL:\\\, DEGREE)))))
+
+(DEFMACRO %UFTRUNCATE (INT REM FLOAT &OPTIONAL DIVISOR) (IL:* IL:|;;| "As in truncate. Assumes FLOAT and DIVISOR are unboxed floatp's. ") (IF DIVISOR (IL:BQUOTE (LET ((FFLOAT (IL:\\\, FLOAT)) (FDIVISOR (IL:\\\, DIVISOR))) (DECLARE (TYPE FLOAT FFLOAT FDIVISOR)) (SETQ (IL:\\\, INT) (IL:UFIX (IL:FQUOTIENT FFLOAT FDIVISOR))) (SETQ (IL:\\\, REM) (- FFLOAT (* FDIVISOR (FLOAT (IL:\\\, INT))))) NIL)) (IL:BQUOTE (LET ((FFLOAT (IL:\\\, FLOAT))) (DECLARE (TYPE FLOAT FFLOAT)) (SETQ (IL:\\\, INT) (IL:UFIX FFLOAT)) (SETQ (IL:\\\, REM) (- FFLOAT (FLOAT (IL:\\\, INT)))) NIL))))
+
+(DEFMACRO %UMAKE-FLOAT (SIGN EXP HI LOW) (IL:* IL:|;;| "as in \\makefloat -- but produces an unboxed number") (IL:BQUOTE (IL:\\FLOATBOX ((IL:OPENLAMBDA (SIGN EXP HI LO) (IL:.LRSH8. HI LO) (SETQ HI (+ (ASH EXP 7) (LOGAND 127 HI))) (IF (EQ SIGN 1) (SETQ HI (LOGIOR IL:\\SIGNBIT HI))) (IL:\\VAG2 HI LO)) (IL:\\\, SIGN) (IL:\\\, EXP) (IL:\\\, HI) (IL:\\\, LOW)))))
+)
+
+
+
+(IL:* IL:|;;| " Unpack floating point functions")

+
+
+(DEFUN DECODE-FLOAT (FLOAT) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0.0 0 1.0) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (VALUES (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO) (- EXP (1- IL:\\EXPONENT.BIAS)) (IF (EQ SIGN 0) 1.0 -1.0)))))
+
+(DEFUN SCALE-FLOAT (FLOAT INTEGER &OPTIONAL OLD-BOX) (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) 0.0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO) (IL:\\MAKEFLOAT SIGN (+ EXP INTEGER) HI LO NIL OLD-BOX))))
+
+(DEFUN FLOAT-RADIX (FLOAT) 2)
+
+(DEFUN FLOAT-SIGN (FLOAT1 &OPTIONAL FLOAT2 OLD-BOX) (IL:* IL:|;;| "Old-box is a floatp box to reuse (may be eq to float2)") (IF (FLOATP FLOAT1) (IF (NULL FLOAT2) (IF (MINUSP FLOAT1) -1.0 1.0) (IF (FLOATP FLOAT2) (IF (EQ (MINUSP FLOAT1) (MINUSP FLOAT2)) FLOAT2 (IF (FLOATP OLD-BOX) (LET ((NEW-SIGN-BIT (IF (EQ 0 (IL:FETCH (IL:FLOATP IL:SIGNBIT) IL:OF FLOAT2)) 1 0))) (IL:* IL:|;;| "Now smash the old-box") (IL:\\PUTBASEFLOATP OLD-BOX 0 FLOAT2) (IL:|replace| (IL:FLOATP IL:SIGNBIT) IL:|of| OLD-BOX IL:|with| NEW-SIGN-BIT) OLD-BOX) (- FLOAT2))) (%NOT-FLOAT-ERROR FLOAT2))) (%NOT-FLOAT-ERROR FLOAT1)))
+
+(DEFUN FLOAT-DIGITS (FLOAT) (IF (FLOATP FLOAT) 24 (%NOT-FLOAT-ERROR FLOAT)))
+
+(DEFUN FLOAT-PRECISION (FLOAT) (IF (FLOATP FLOAT) (IF (= FLOAT 0.0) 0 (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (IF (< HI IL:\\HIDDENBIT) (IL:* IL:\; "Denormalized number") (IF (EQ HI 0) (INTEGER-LENGTH LO) (+ 16 (INTEGER-LENGTH HI))) (IL:* IL:\; "Normalized number") 24))) (%NOT-FLOAT-ERROR FLOAT)))
+
+(DEFUN INTEGER-DECODE-FLOAT (FLOAT) (IL:* IL:|;;| "As in decode-float -- but returns integers") (SETQ FLOAT (FLOAT FLOAT)) (IF (= FLOAT 0.0) (VALUES 0 0 1) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX FLOAT SIGN EXP HI LO T) (VALUES (+ (ASH HI 16) LO) (- EXP (+ IL:\\EXPONENT.BIAS 23)) (IF (EQ SIGN 0) 1 -1)))))
+
+
+
+(IL:* IL:|;;| "Exp  (e to the power x)")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %LOG-BASE2-E (%FLOAT 16312 43579))
+)
+
+(XCL:DEFGLOBALVAR %EXP-POLY (IL:* IL:|;;| "%EXP-POLY contains P and Q coefficients of Hart et al EXPB 1103 rational approximation to (EXPT 2 X) in interval (0 .125).   ") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 15549 17659) (%FLOAT 16256 0) (%FLOAT 16801 38273) (%FLOAT 17257 7717) (%FLOAT 17597 11739) (%FLOAT 17800 30401))))
+
+(XCL:DEFGLOBALVAR %EXP-TABLE (IL:* IL:|;;| "  %EXP-TABLE contains values of powers (EXPT 2 (/ N 8))  . ") (MAKE-ARRAY 8 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 16267 38338) (%FLOAT 16280 14320) (%FLOAT 16293 65239) (%FLOAT 16309 1267) (%FLOAT 16325 26410) (%FLOAT 16343 17661) (%FLOAT 16362 49351))))
+
+(DEFUN %EXP-FLOAT (X) (IL:* IL:|;;| "(CL:EXP X) for float X calculated via EXPB 1103 rational approximation of Hart et al. ") (LET ((FX (FLOAT X)) R M N ANSWER RECIPFLG) (DECLARE (TYPE FLOAT FX R)) (IL:* IL:|;;| "First, arrange X to be in interval (0 infinity) via identity (CL:EXP (minus X)) = (/ 1.0 (CL:EXP X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ FX (IL:UFMINUS FX)) (SETQ RECIPFLG T)) (IL:* IL:|;;| "Next, the problem of (CL:EXP X) is converted into a problem (EXPT 2 Y) where Y = (* %LOG-BASE2-E X).   ") (IL:* IL:|;;| "Then range reduction is accomplished via (EXPT 2 Y) = (* (EXPT 2 M) (EXPT 2 (/ N 8)) (EXPT 2 R)) where M and N are integers and R is a float in the interval (0.0 .125).   ") (IL:* IL:|;;| "After M, N, R are determined, (EXPT 2 M) is effected by scaling, (EXPT 2 (/ N 8)) is found by table lookup, and (EXPT 2 R) is calculated by rational approximation EXPB 1103 of Hart et al.  ") (%UFTRUNCATE M R (* %LOG-BASE2-E FX)) (%UFTRUNCATE N R R 0.125) (SETQ FX (IL:FTIMES (%GET-TABLE-ENTRY %EXP-TABLE N) (IL:FQUOTIENT (%POLYEVAL R %EXP-POLY 5) (%POLYEVAL (IL:UFMINUS R) %EXP-POLY 5)))) (COND (RECIPFLG (SETQ ANSWER (SETQ FX (IL:FQUOTIENT 1.0 FX))) (SCALE-FLOAT ANSWER (- M) ANSWER)) (T (SETQ ANSWER FX) (SCALE-FLOAT ANSWER M ANSWER)))))
+
+(DEFUN EXP (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((EXP (%EXP-FLOAT (COMPLEX-REALPART NUMBER))) (Y (COMPLEX-IMAGPART NUMBER))) (COMPLEX (* EXP (COS Y)) (* EXP (SIN Y))))) (NUMBER (%EXP-FLOAT NUMBER)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+
+
+(IL:* IL:|;;| "Expt (x to the power y)")

+
+
+(DEFUN %EXPT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is an integer and POWER is an integer. ") (COND ((MINUSP POWER) (/ (%EXPT-INTEGER BASE (- POWER)))) ((EQ BASE 2) (ASH 1 POWER)) (T (IL:* IL:|;;| "Integer to positive integer power") (IL:* IL:\; "Must check first for infinity cases") (COND ((EQ BASE IL:MIN.INTEGER) (IF (INTEGERP POWER) (COND ((< POWER 0) 0) ((EQ POWER 0) 1) ((EQ POWER IL:MAX.INTEGER) (ERROR "Can't raise negative infinity to infinite power.")) ((EVENP POWER) IL:MAX.INTEGER) (T (IL:* IL:\; "Odd integer POWER") IL:MIN.INTEGER)) (ERROR "Can't raise negative infinity to noninteger power." POWER))) ((EQ BASE IL:MAX.INTEGER) (IF (EQ POWER 0) 1 IL:MAX.INTEGER)) ((EQ POWER IL:MAX.INTEGER) (COND ((EQ BASE 0) 0) ((> BASE 0) IL:MAX.INTEGER) (T (ERROR "Can't expt negative number to infinite power.")))) (T (LET ((TOTAL 1)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* BASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ BASE (* BASE BASE)))))))))
+
+(DEFUN %EXPT-FLOAT-INTEGER (BASE POWER) (IL:* IL:|;;| "(EXPT BASE POWER) where BASE is a float and POWER is an integer. ") (COND ((MINUSP POWER) (IL:FQUOTIENT 1.0 (%EXPT-FLOAT-INTEGER BASE (- POWER)))) (T (IL:* IL:|;;| "float to positive integer power") (LET ((FBASE (FLOAT BASE)) (TOTAL 1.0)) (DECLARE (TYPE FLOAT FBASE TOTAL)) (LOOP (IF (ODDP POWER) (SETQ TOTAL (* FBASE TOTAL))) (SETQ POWER (ASH POWER -1)) (IF (EQ 0 POWER) (RETURN TOTAL)) (SETQ FBASE (* FBASE FBASE)))))))
+
+(DEFUN EXPT (BASE-NUMBER POWER-NUMBER) (IL:* IL:|;;| "This function calculates BASE-NUMBER raised to the nth power.  It separates the cases by the type of POWER-NUMBER for efficiency reasons, as powers can be calculated more efficiently if POWER-NUMBER is a positive integer, Therefore, All integer values of POWER-NUMBER are calculated as positive integers, and inverted if negative. ") (TYPECASE POWER-NUMBER (INTEGER (IF (EQ POWER-NUMBER 0) (TYPECASE BASE-NUMBER (FLOAT 1.0) ((COMPLEX FLOAT) (COMPLEX 1.0 0.0)) (NUMBER 1) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))) (TYPECASE BASE-NUMBER (INTEGER (%EXPT-INTEGER BASE-NUMBER POWER-NUMBER)) (RATIO (%MAKE-RATIO (%EXPT-INTEGER (RATIO-NUMERATOR BASE-NUMBER) POWER-NUMBER) (%EXPT-INTEGER (RATIO-DENOMINATOR BASE-NUMBER) POWER-NUMBER))) (FLOAT (%EXPT-FLOAT-INTEGER BASE-NUMBER POWER-NUMBER)) (COMPLEX (* (%EXPT-FLOAT-INTEGER (%COMPLEX-ABS BASE-NUMBER) POWER-NUMBER) (CIS (* POWER-NUMBER (PHASE BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR BASE-NUMBER))))) (NUMBER (IF (= BASE-NUMBER 0) BASE-NUMBER (EXP (* POWER-NUMBER (LOG BASE-NUMBER))))) (OTHERWISE (%NOT-NUMBER-ERROR POWER-NUMBER))))
+
+
+
+(IL:* IL:|;;| "Log (log base e)")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %LOG2 (%FLOAT 16177 29208))
+
+(DEFCONSTANT %SQRT2 (%FLOAT 16309 1267))
+)
+
+(XCL:DEFGLOBALVAR %LOG-PPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16042 22803) (%FLOAT 49484 23590) (%FLOAT 17044 17982) (%FLOAT 49926 37153) (%FLOAT 17046 5367))))
+
+(XCL:DEFGLOBALVAR %LOG-QPOLY (IL:* IL:|;;| "%LOG-PPOLY and %LOG-QPOLY contain P and Q coefficients of Hart et al LOGE 2707 rational approximation to (LOG X) in interval ((SQRT .5) (SQRT 2))") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49512 9103) (%FLOAT 16992 42274) (%FLOAT 49823 38048) (%FLOAT 16918 5367))))
+
+(DEFUN %LOG-FLOAT (X) (IL:* IL:|;;| "(LOG X) for positive float X. ") (IF (<= (SETQ X (FLOAT X)) 0.0) (ERROR "Log of zero: ~s" X)) (IL:* IL:|;;| "Range reduce to an R in interval ((SQRT 0.5) (SQRT 2)) via identity (LOG X) = (+ (LOG R) (* %LOG-2 EXP)) for a suitable integer EXP.  exp is found from the  exponent field of the iee floating point number representation of x.") (LET (R EXP ANSWER) (DECLARE (TYPE FLOAT R)) (LET (SIGN HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (SETQ EXP (- EXP IL:\\EXPONENT.BIAS)) (SETQ R (%UMAKE-FLOAT SIGN IL:\\EXPONENT.BIAS HI LO)) NIL) (WHEN (IL:UFGREATERP R %SQRT2) (SETQ EXP (1+ EXP)) (SETQ R (IL:FQUOTIENT R 2.0))) (IL:* IL:|;;| "(LOG R) is calculated by rational approximation LOGE 2707 of Hart et al.") (LET* ((Z (IL:FQUOTIENT (1- R) (1+ R))) (Z2 (* Z Z))) (DECLARE (TYPE FLOAT Z Z2)) (SETQ ANSWER (SETQ R (+ (* Z (IL:FQUOTIENT (%POLYEVAL Z2 %LOG-PPOLY 4) (%POLYEVAL Z2 %LOG-QPOLY 4))) (* %LOG2 EXP))))) ANSWER))
+
+(DEFUN LOG (NUMBER &OPTIONAL BASE) (IF BASE (IL:QUOTIENT (LOG NUMBER) (LOG BASE)) (TYPECASE NUMBER ((OR FLOAT RATIONAL) (IF (MINUSP NUMBER) (COMPLEX (%LOG-FLOAT (- NUMBER)) PI) (%LOG-FLOAT NUMBER))) (COMPLEX (COMPLEX (%LOG-FLOAT (%COMPLEX-ABS NUMBER)) (PHASE NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))
+
+
+
+(IL:* IL:|;;| "Sqrt")

+
+
+(DEFUN %SQRT-FLOAT (X) (IL:* IL:|;;| "(SQRT X) for nonnegative float X") (SETQ X (FLOAT X)) (IF (<= X 0.0) 0.0 (LET ((FX X) V) (DECLARE (TYPE FLOAT FX V)) (LET (SIGN EXP HI LO) (%FLOAT-UNBOX X SIGN EXP HI LO) (IL:* IL:|;;| "First guess") (SETQ V (%UMAKE-FLOAT 0 (+ (ASH EXP -1) (IL:CONSTANT (1+ (ASH IL:\\EXPONENT.BIAS -1)))) HI LO)) NIL) (IL:* IL:|;;| "Four step newton-raphson") (DOTIMES (I 4 V) (SETQ V (* 0.5 (+ V (IL:FQUOTIENT FX V))))))))
+
+(DEFUN %SQRT-COMPLEX (Z) (IL:* IL:|;;| "(SQRT X) for complex X. ") (LET ((R (FLOAT (COMPLEX-REALPART Z))) (I (FLOAT (COMPLEX-IMAGPART Z))) (ABS (SQRT (ABS Z))) (PHASE (IL:FQUOTIENT (PHASE Z) 2.0)) C D E ANSWER) (DECLARE (TYPE FLOAT ABS R I)) (IL:* IL:|;;| "Newton's method.") (LET ((C (* ABS (COS PHASE))) (D (* ABS (SIN PHASE))) E) (DECLARE (TYPE FLOAT C D E)) (DOTIMES (K 4 (COMPLEX C D)) (SETQ E (+ (* C C) (* D D))) (SETQ C (* 0.5 (+ C (IL:FQUOTIENT (+ (* R C) (* I D)) E)))) (SETQ D (* 0.5 (+ D (IL:FQUOTIENT (- (* I C) (* R D)) E))))))))
+
+(DEFUN SQRT (NUMBER) (IF (= NUMBER 0) 0.0 (TYPECASE NUMBER (COMPLEX (%SQRT-COMPLEX NUMBER)) (NUMBER (IF (MINUSP NUMBER) (IL:* IL:\; "Negative real axis maps into positive imaginary axis.") (COMPLEX 0 (SQRT (- NUMBER))) (%SQRT-FLOAT NUMBER))) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER)))))
+
+
+
+(IL:* IL:|;;| "Sin and Cos")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %SIN-EPSILON (IL:* IL:|;;| "%SIN-EPSILON is sufficiently small that (SIN X) = X for X in interval (0 %SIN-EPSILON).  It suffices to take %SIN-EPSILON a little bit smaller than (SQRT (* 6 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (SIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %SIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %SIN-PPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)).  The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0)))") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 45236 25611) (%FLOAT 13589 26148) (%FLOAT 47286 34797) (%FLOAT 15295 3306) (%FLOAT 48666 34805) (%FLOAT 16256 0))))
+
+(XCL:DEFGLOBALVAR %SIN-QPOLY (IL:* IL:|;;| "%SIN-PPOLY and %SIN-QPOLY contain adapted P and Q coefficients of Hart et al SIN 3374 rational approximation to (SIN X) in interval (0 (/ PI 2)).  The coefficients for %SIN-PPOLY and %SIN-QPOLY have been computed from Hart using extended precision routines and the relations %SIN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 2 PI) (1+ (* 2 I))) ENTRY) Q0))) and %SIN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 2 PI) (* 2 I)) ENTRY) Q0))) *") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 11384 52865) (%FLOAT 12553 9550) (%FLOAT 13604 38385) (%FLOAT 14593 18841) (%FLOAT 15489 5549) (%FLOAT 16256 0))))
+
+(DEFUN %SIN-FLOAT (X COS-FLG) (IL:* IL:|;;| "SIN of a FLOAT X calculated via SIN 3374 rational approximation of Hart et al.  ") (LET ((THETA (FLOAT X)) (SIGN 1.0) SIGN) (DECLARE (TYPE FLOAT THETA SIGN)) (IL:* IL:|;;| "If this function is called by COS then use (COS X) = (SIN (-- %PI/2 X)) = (SIN (+ %PI/2 X)). Case out on sign of X for improved numerical stability.  Avoids unnecessary rounding and promotes symmetric properties.  (COS X) = (COS (-- X)) is guaranteed by this strategy.") (IF COS-FLG (IF (IL:UFGREATERP THETA 0.0) (SETQ THETA (- %PI/2 THETA)) (SETQ THETA (+ %PI/2 THETA)))) (IL:* IL:|;;| "First range reduce to (0 infinity) by (SIN (minus X)) = (minus (SIN X)) This strategy guarantees (SIN (minus X)) = (minus (SIN X))") (WHEN (IL:UFLESSP THETA 0.0) (SETQ SIGN -1.0) (SETQ THETA (IL:UFMINUS THETA))) (IL:* IL:|;;| "Next range reduce to interval (0 %2PI) by (SIN X) = (SIN (MOD X %2PI)) ") (IF (IL:UFGEQ THETA %2PI) (SETQ THETA (- THETA (* %2PI (FLOAT (IL:UFIX (IL:FQUOTIENT THETA %2PI))))))) (IL:* IL:|;;| "Next range reduce to interval (0 PI) by (SIN (+ X PI)) = (minus (SIN X)) ") (WHEN (IL:UFGREATERP THETA PI) (SETQ THETA (- THETA PI)) (SETQ SIGN (IL:UFMINUS SIGN))) (IL:* IL:|;;| "Next range reduce to interval (0 %PI/2) by (SIN (+ X %PI/2)) = (SIN (minus %PI/2 X))") (IF (IL:UFGREATERP THETA %PI/2) (SETQ THETA (- PI THETA))) (IF (IL:UFLESSP THETA %SIN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %SIN-EPSILON) then (SIN R) = R to the precision that we can offer.  Return R because (1) it is desirable that (SIN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R") (SETQ THETA (* SIGN THETA)) (IL:* IL:|;;| "Now use SIN 3374 rational approximation of Harris et al.  which works on interval (0 %PI/2) ") (LET ((R2 (* THETA THETA))) (DECLARE (TYPE FLOAT R2)) (SETQ THETA (* SIGN THETA (IL:FQUOTIENT (%POLYEVAL R2 %SIN-PPOLY 5) (%POLYEVAL R2 %SIN-QPOLY 5))))))))
+
+(DEFUN SIN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (SIN X) (COSH Y)) (* (COS X) (SINH Y))))) (NUMBER (%SIN-FLOAT RADIANS NIL)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+(DEFUN COS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((X (COMPLEX-REALPART RADIANS)) (Y (COMPLEX-IMAGPART RADIANS))) (COMPLEX (* (COS X) (COSH Y)) (- (* (SIN X) (SINH Y)))))) (NUMBER (%SIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Tan")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %TAN-EPSILON (IL:* IL:|;;| "%TAN-EPSILON is sufficiently small that (TAN X) = X for X in interval (0 %TAN-EPSILON).  It suffices to take %TAN-EPSILON a little bit smaller than (SQRT (* 3 SINGLE-FLOAT-EPSILON)) which we get by the Taylor series expansion (TAN X) = (+ X (/ (EXPT X 3) 3) ...) (The relative error caused by ommitting (/ (EXPT X 3) 3) isn't observable.) Comparison against %TAN-EPSILON is used to avoid POLYEVAL microcode underflow when computing TAN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %TAN-PPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4).  The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 5 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 13237 21090) (%FLOAT 47141 15825) (%FLOAT 15246 8785) (%FLOAT 48655 48761) (%FLOAT 16256 0))))
+
+(XCL:DEFGLOBALVAR %TAN-QPOLY (IL:* IL:|;;| "%TAN-PPOLY and %TAN-QPOLY contain adapted P and Q coefficients of Hart et al TAN 4288 rational approximation to (TAN X) in interval (-PI/4 PI/4).  The coefficients for %TAN-PPOLY and %TAN-QPOLY have been computed from Hart using extended precision routines and the relations %TAN-PPOLY = (REVERSE (for I from 0 as ENTRY in PS collect (/ (* (EXPT (/ 4 PI) (1+ (* 2 I))) ENTRY) Q0))) and %TAN-QPOLY = (REVERSE (for I from 0 as ENTRY in QS collect (/ (* (EXPT (/ 4 PI) (* 2 I)) ENTRY) Q0))) ") (MAKE-ARRAY 6 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 45267 36947) (%FLOAT 13848 46875) (%FLOAT 47612 53738) (%FLOAT 15596 52854) (%FLOAT 48882 35303) (%FLOAT 16256 0))))
+
+(DEFUN %TAN-FLOAT (X) (IL:* IL:|;;| "TAN of a FLOAT X calculated via TAN 4288 rational approximation of Hart et al.") (LET ((FX (FLOAT X)) (SIGN 1.0) RECIPFLG) (DECLARE (TYPE FLOAT FX SIGN)) (IL:* IL:|;;| "First range reduce to (0 infinity) by (TAN (minus X)) = (minus (TAN X))") (WHEN (IL:UFLESSP FX 0.0) (SETQ SIGN -1.0) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Next range reduce to (0 PI)") (IF (IL:UFGEQ FX PI) (SETQ FX (- FX (* PI (FLOAT (IL:UFIX (IL:FQUOTIENT FX PI))))))) (IL:* IL:|;;| "Next, range reduce to (-PI/4 PI/4) using (TAN X) = (TAN (minus X PI)) to get into interval (-PI/2 PI/2) and then (TAN X) = (/ (TAN (minus PI/2 X))) to get into interval (-PI/4 PI/4) ") (COND ((IL:UFGREATERP FX %PI/2) (SETQ FX (- FX PI)) (WHEN (IL:UFLESSP FX %-PI/4) (SETQ RECIPFLG T) (SETQ FX (- %-PI/2 FX)))) (T (WHEN (IL:UFGREATERP FX %PI/4) (SETQ RECIPFLG T) (SETQ FX (- %PI/2 FX))))) (COND ((IL:UFLESSP (IL:UFABS FX) %TAN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %TAN-EPSILON) then (TAN R) = R to the precision that we can offer.  Return R because (1) it is desirable that (TAN R) = R exactly for small R and (2) microcode POLYEVAL will underflow on sufficiently small positive R.") (SETQ FX (* SIGN FX)) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX)) (T (IL:* IL:|;;| "Now use TAN 4288 rational approximation of Hart et al.  which works on interval (0 %PI/4)") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* SIGN FX (IL:FQUOTIENT (%POLYEVAL R2 %TAN-PPOLY 4) (%POLYEVAL R2 %TAN-QPOLY 5)))) (IF RECIPFLG (SETQ FX (IL:FQUOTIENT 1.0 FX)) FX))))))
+
+(DEFUN TAN (RADIANS) (TYPECASE RADIANS (COMPLEX (LET* ((X (* 2.0 (COMPLEX-REALPART RADIANS))) (Y (* 2.0 (COMPLEX-IMAGPART RADIANS))) (DENOM (+ (COS X) (COSH Y)))) (COMPLEX (IL:QUOTIENT (SIN X) DENOM) (IL:QUOTIENT (SINH Y) DENOM)))) (NUMBER (%TAN-FLOAT RADIANS)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Asin and Acos")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %ASIN-EPSILON (IL:* IL:|;;| "%ASIN-EPSILON is sufficiently small that (ASIN X) = X for X in interval (0 %ASIN-EPSILON).  It suffices to take %ASIN-EPSILON a little bit smaller than (* 2 SINGLE-FLOAT-EPSILON) which we get by the Taylor series expansion (ASIN X) = (+ X (/ (EXPT X 3) 6) ...) (The relative error caused by ommitting (/ (EXPT X 3) 6) isn't observable.) Comparison against %ASIN-EPSILON is used to avoid POLYEVAL microcode underflow when computing SIN.") (%FLOAT 14720 0))
+)
+
+(XCL:DEFGLOBALVAR %ASIN-PPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16007 50045) (%FLOAT 49549 8020) (%FLOAT 17236 15848) (%FLOAT 50285 63464) (%FLOAT 17650 31235) (%FLOAT 50403 62852) (%FLOAT 17440 39471))))
+
+(XCL:DEFGLOBALVAR %ASIN-QPOLY (IL:* IL:|;;| "%ASIN-PPOLY and %ASIN-QPOLY contain P and Q coefficients of Hart et al ARCSN 4671 rational approximation to (ASIN X) in interval (0 (SQRT .5)).") (MAKE-ARRAY 7 :ELEMENT-TYPE (QUOTE SINGLE-FLOAT) :INITIAL-CONTENTS (LIST (%FLOAT 16256 0) (%FLOAT 49672 25817) (%FLOAT 17308 55260) (%FLOAT 50326 38098) (%FLOAT 17674 22210) (%FLOAT 50417 22451) (%FLOAT 17440 39471))))
+
+(DEFUN %ASIN-FLOAT (X ACOS-FLG) (IL:* IL:|;;| "(ASIN X) for float X calculated via ARCSN 4671 rational approximation of Hart et al.") (IF (OR (< X -1.0) (> X 1.0)) (ERROR "Arg not in range: ~s" X)) (LET ((FX (FLOAT X)) NEGATIVE REDUCED) (DECLARE (TYPE FLOAT FX)) (IL:* IL:|;;| "Range reduce to (0 1) via identity (ASIN (minus X)) = (minus (ASIN X)) ") (WHEN (IL:UFLESSP FX 0.0) (SETQ NEGATIVE T) (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "Range reduce to (0 0.5) via identity (ASIN X) = (minus %PI/2 (* 2.0 (ASIN (SQRT (* 0.5 (minus 1.0 R)))))) Avoids numerical instability calculating (ASIN X) for X near one.  SIN is horizontally flat near %PI/2 so calculating (ASIN X) by rational approximation wouldn't work well for X near (SIN %PI/2) = 1") (WHEN (IL:UFGREATERP FX 0.5) (SETQ REDUCED T) (SETQ FX (SQRT (SETQ FX (* 0.5 (- 1.0 FX)))))) (IL:* IL:|;;| "R is now in range (0 0.5) Use ARCSN 4671 rational approximation to calculate (ASIN R) ") (IF (IL:UFGREATERP FX %ASIN-EPSILON) (IL:* IL:|;;| "If R is in the interval (0 %SIN-EPSILON) then (ASIN R) = R to the precision that we can offer. ") (LET ((R2 (* FX FX))) (DECLARE (TYPE FLOAT R2)) (SETQ FX (* FX (IL:QUOTIENT (%POLYEVAL R2 %ASIN-PPOLY 6) (%POLYEVAL R2 %ASIN-QPOLY 6)))) NIL)) (IF REDUCED (SETQ FX (- %PI/2 (* 2.0 FX)))) (IF NEGATIVE (SETQ FX (IL:UFMINUS FX))) (IL:* IL:|;;| "In case we want (ACOS X) then use identity (ACOS X) = (minus %PI/2 (ASIN X))") (IF ACOS-FLG (SETQ FX (- %PI/2 FX))) FX))
+
+(DEFUN ASIN (NUMBER) (TYPECASE NUMBER (COMPLEX (LET ((Z (LOG (+ (COMPLEX (- (COMPLEX-IMAGPART NUMBER)) (COMPLEX-REALPART NUMBER)) (SQRT (- 1 (* NUMBER NUMBER))))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT NUMBER NIL)) (OTHERWISE (%NOT-NUMBER-ERROR NUMBER))))
+
+(DEFUN ACOS (RADIANS) (TYPECASE RADIANS (COMPLEX (LET ((Z (SQRT (- 1 (* RADIANS RADIANS))))) (SETQ Z (LOG (+ RADIANS (COMPLEX (- (COMPLEX-IMAGPART Z)) (COMPLEX-REALPART Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z))))) (NUMBER (%ASIN-FLOAT RADIANS T)) (OTHERWISE (%NOT-NUMBER-ERROR RADIANS))))
+
+
+
+(IL:* IL:|;;| "Atan ")

+
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT %SQRT3 (%FLOAT 16349 46039))
+
+(DEFCONSTANT %2-SQRT3 (%FLOAT 16009 12451))
+
+(DEFCONSTANT %INV-2-SQRT3 (%FLOAT 16494 55788))
+)
+
+(DEFUN %ATAN-FLOAT (Y &OPTIONAL X) (LET ((FY (FLOAT Y)) FX FARG) (DECLARE (TYPE FLOAT FY FX FARG)) (IL:* IL:|;;| "Compute farg") (COND ((NULL X) (IF (= Y 0.0) (RETURN-FROM %ATAN-FLOAT 0.0) (SETQ FARG FY))) (T (IL:* IL:|;;| "Don't use unboxed version of =, because it doesn't return t on comparison of 0.0 and -0.0") (SETQ FX (FLOAT X)) (COND ((= X 0.0) (IF (= Y 0.0) (ERROR "Both args to atan are 0.0") (RETURN-FROM %ATAN-FLOAT (IF (> Y 0.0) %PI/2 (- %PI/2))))) ((= Y 0.0) (RETURN-FROM %ATAN-FLOAT (IF (> X 0.0) 0.0 PI))) ((> Y 0.0) (IF (> X 0.0) (SETQ FARG (IL:FQUOTIENT FY FX)) (SETQ FARG (IL:FQUOTIENT (IL:UFMINUS FY) FX)))) ((> X 0.0) (SETQ FARG (IL:FQUOTIENT FY (IL:UFMINUS FX)))) (T (SETQ FARG (IL:FQUOTIENT FY FX)))))) (IL:* IL:|;;| "Compute result") (LET ((CONSTANT 0.0) (CONSTANT-FLAG T) NEGATE-FLAG ADD-FLAG) (DECLARE (TYPE FLOAT CONSTANT)) (IL:* IL:|;;| "(ATAN (minus X)) = (minus (ATAN X)) ") (WHEN (IL:UFLESSP FARG 0.0) (SETQ NEGATE-FLAG T) (SETQ FARG (IL:UFMINUS FARG))) (IL:* IL:|;;| "Range reduce to (0, 2-sqrt(3))") (COND ((IL:UFGEQ FARG %INV-2-SQRT3) (IL:* IL:|;;| "(ATAN X) = (minus %PI/2 (ATAN (/ X)))") (SETQ CONSTANT %PI/2) (SETQ FARG (IL:FQUOTIENT 1.0 FARG))) ((IL:UFGEQ FARG 1.0) (SETQ CONSTANT %PI/3) (SETQ FARG (IL:FQUOTIENT (- %SQRT3 FARG) (+ 1.0 (* FARG %SQRT3))))) ((IL:UFGEQ FARG %2-SQRT3) (SETQ ADD-FLAG T) (SETQ CONSTANT %PI/6) (SETQ FARG (IL:FQUOTIENT (- (* FARG %SQRT3) 1.0) (+ %SQRT3 FARG)))) (T (SETQ CONSTANT-FLAG NIL))) (IL:* IL:|;;| "Power series expansion cons'ed up on the fly") (LET ((SQR (IL:UFMINUS (* FARG FARG))) (INT 1.0) (POW FARG) (OLD 0.0)) (DECLARE (TYPE FLOAT SQR INT POW OLD)) (LOOP (IF (IL:UFEQP FARG OLD) (RETURN NIL)) (SETQ INT (+ INT 2.0)) (SETQ POW (* POW SQR)) (SETQ OLD FARG) (SETQ FARG (+ FARG (IL:FQUOTIENT POW INT))))) (IF CONSTANT-FLAG (IF ADD-FLAG (SETQ FARG (+ CONSTANT FARG)) (SETQ FARG (- CONSTANT FARG)))) (IF NEGATE-FLAG (SETQ FARG (IL:UFMINUS FARG)))) (IL:* IL:|;;| "Fix up") (IF X (COND ((IL:UFGREATERP FY 0.0) (IF (IL:UFLESSP FX 0.0) (SETQ FARG (- PI FARG)))) ((IL:UFGREATERP FX 0.0) (SETQ FARG (IL:UFMINUS FARG))) (T (SETQ FARG (- FARG PI))))) (IL:* IL:|;;| "Box and return") FARG))
+
+(DEFUN ATAN (Y &OPTIONAL X) (COND (X (%ATAN-FLOAT (FLOAT Y) (FLOAT X))) ((COMPLEXP Y) (LET ((R (COMPLEX-REALPART Y)) (I (COMPLEX-IMAGPART Y))) (IF (NOT (AND (ZEROP R) (= (ABS I) 1))) (LET ((Z (COMPLEX (- I) R))) (SETQ Z (* 0.5 (LOG (/ (+ 1 Z) (- 1 Z))))) (COMPLEX (COMPLEX-IMAGPART Z) (- (COMPLEX-REALPART Z)))) (ERROR "Argument not in domain for atan. ~S" Y)))) (T (%ATAN-FLOAT Y))))
+
+
+
+(IL:* IL:|;;| "Cis (exp (i x))")

+
+
+(DEFUN CIS (RADIANS) (IF (TYPEP RADIANS (QUOTE (AND NUMBER (NOT COMPLEX)))) (COMPLEX (%SIN-FLOAT RADIANS T) (%SIN-FLOAT RADIANS)) (%NOT-NONCOMPLEX-NUMBER-ERROR RADIANS)))
+
+
+
+(IL:* IL:|;;| "Sinh, Cosh Tanh")

+
+
+(DEFUN SINH (NUMBER) (IL:* IL:|;;| "Computed directly from its ") (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (- Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (- FZ (IL:FQUOTIENT 1.0 FZ)) 2.0)))))
+
+(DEFUN COSH (NUMBER) (IF (COMPLEXP NUMBER) (LET ((Z (EXP NUMBER))) (/ (+ Z (/ Z)) 2)) (LET ((FZ (%EXP-FLOAT NUMBER))) (DECLARE (TYPE FLOAT FZ)) (SETQ FZ (IL:FQUOTIENT (+ FZ (IL:FQUOTIENT 1.0 FZ)) 2.0)))))
+
+(DEFUN TANH (NUMBER) (IF (COMPLEXP NUMBER) (/ (SINH NUMBER) (COSH NUMBER)) (LET* ((FX (%EXP-FLOAT (* 2 NUMBER))) (FY (IL:FQUOTIENT 1.0 FX))) (DECLARE (TYPE FLOAT FX FY)) (SETQ FX (- (IL:FQUOTIENT 1.0 (+ 1.0 FY)) (IL:FQUOTIENT 1.0 (+ 1.0 FX)))))))
+
+
+
+(IL:* IL:|;;| "Asinh Acosh Atanh")

+
+
+(DEFUN ASINH (NUMBER) (IF (COMPLEXP NUMBER) (LOG (+ NUMBER (SQRT (+ (* NUMBER NUMBER) 1)))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (+ (* FX FX) 1.0)))))))))
+
+(DEFUN ACOSH (NUMBER) (IF (OR (COMPLEXP NUMBER) (< NUMBER 1)) (LOG (+ NUMBER (* (+ NUMBER 1) (SQRT (/ (- NUMBER 1) (+ NUMBER 1)))))) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (LOG (SETQ BOX (+ FX (SQRT (SETQ BOX (- (* FX FX) 1.0)))))))))
+
+(DEFUN ATANH (NUMBER) (IF (OR (COMPLEXP NUMBER) (> (ABS NUMBER) 1)) (IF (AND (ZEROP (IMAGPART NUMBER)) (= (ABS (REALPART NUMBER)) 1)) (ERROR "Argument out of range. ~s" NUMBER) (* 0.5 (LOG (/ (+ 1 NUMBER) (- 1 NUMBER))))) (IF (= NUMBER 1.0) (ERROR "Argument out of range. ~s" NUMBER) (LET ((FX (FLOAT NUMBER)) BOX) (DECLARE (TYPE FLOAT FX BOX)) (SETQ BOX (* 0.5 (LOG (SETQ BOX (IL:FQUOTIENT (+ 1.0 FX) (- 1.0 FX))))))))))
+
+
+
+(IL:* IL:|;;| "rational and rationalize ")

+
+
+(DEFUN %RATIONAL-FLOAT (NUMBER) (IF (= NUMBER 0.0) 0 (LET (SIGN EXP HI LO MANT) (%FLOAT-UNBOX NUMBER SIGN EXP HI LO T) (SETQ MANT (+ (ASH HI 16) LO)) (IF (EQ SIGN 1) (SETQ MANT (- MANT))) (SETQ EXP (- EXP 23 IL:\\EXPONENT.BIAS)) (IF (< EXP 0) (%BUILD-RATIO MANT (ASH 1 (- EXP))) (ASH MANT EXP)))))
+
+(DEFUN %RATIONALIZE-FLOAT (X) (IL:* IL:|;;| "Produce a rational approximating X.  ") (IL:* IL:|;;| "This routine presupposes familiarity with topics in number theory and IEEE FLOATP representation.  The algorithm uses a standard mathematical technique for approximating a real valued number, but in very sophisticated form more amenable to the computer and the nature of IEEE FLOATPs and is not an algorithm you are likely to find published anywhere.   ") (IF (= X 0.0) (IL:* IL:\; "In case X = 0, just return 0 ") 0 (LET (SIGN EXPT HI LO XNUM XDEN R) (IL:* IL:|;;| "First of all, X is range reduced to the interval ((SQRT .5) (SQRT 2)) excluding (SQRT 2) This strategy has the property that FLOATPs differing only by sign and a power of two rationalize into rationals differing only by sign and a power of two.  The choice of interval ((SQRT .5) (SQRT 2)) versus another interval such as (.5 1) is due to our wanting there to be roughly the same number of significant bits in the numerator as in the denominator of the answer that is returned.  Here, significant bits is taken to mean the number of bits in the results returned by the continued fraction approximation and excludes the bits resulting from multiplying by the power of two.  ") (IL:* IL:\; "Get SIGN XNUM XDEN and EXPT for X.  ") (LET (BIT-SIGN EXP HI LO) (%FLOAT-UNBOX X BIT-SIGN EXP HI LO T) (SETQ XNUM (+ (ASH HI 16) LO)) (SETQ EXPT (- EXP (+ IL:\\EXPONENT.BIAS 23))) (SETQ SIGN (IF (EQ BIT-SIGN 0) 1 -1)) (IL:* IL:\; "Compute r") (LOOP (IF (NOT (EQ 0 (LOGAND HI IL:\\HIDDENBIT))) (RETURN NIL)) (IL:* IL:\; "Handle the denormalized case") (IL:.LLSH1. HI LO)) (IL:.LLSH8. HI LO) (SETQ R (IL:\\MAKEFLOAT 0 (1- IL:\\EXPONENT.BIAS) HI LO))) (IL:* IL:\; "24 because FLOATPs have 24 bit mantissas.  ") (SETQ XDEN (IL:CONSTANT (ASH 1 24))) (SETQ EXPT (+ EXPT 24)) (COND ((< XNUM 11863283) (IL:* IL:\; "11863283 = (SQRT 0.5) mantissa.  ") (SETQ XDEN (ASH XDEN -1)) (SETQ EXPT (1- EXPT)) (SETQ R (* 2 R)))) (IL:* IL:|;;| "At this point, X = (* (/ XNUM XDEN) (EXPT 2 EXPT)) and (/ XNUM XDEN) is in the interval ((SQRT 0.5) (SQRT 2)) ") (LET ((OLDNUM 1) (OLDDEN 0) (NUM 0) (DEN 1)) (IL:* IL:\; "Continued fraction approximation loop.  ") (LOOP (COND ((AND (NOT (EQ DEN 0)) (= (IL:FQUOTIENT NUM DEN) R)) (COND ((> EXPT 0) (SETQ NUM (ASH NUM EXPT))) ((< EXPT 0) (SETQ DEN (ASH DEN (- EXPT))))) (RETURN (/ (* SIGN NUM) DEN)))) (ROTATEF XNUM XDEN) (LET ((TRUNC (IL:IQUOTIENT XNUM XDEN))) (SETQ NUM (+ OLDNUM (* TRUNC (SETQ OLDNUM NUM)))) (SETQ DEN (+ OLDDEN (* TRUNC (SETQ OLDDEN DEN)))) (SETQ XNUM (- XNUM (* XDEN TRUNC)))))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+
+(IL:PUTPROPS IL:CMLFLOAT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+
+(IL:PUTPROPS IL:CMLFLOAT IL:FILETYPE COMPILE-FILE)
+(IL:PUTPROPS IL:CMLFLOAT IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLFLOATARRAY

@@ -0,0 +1,600 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "19-Oct-93 10:48:08" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLFLOATARRAY.;1"
 29993  
+
+      previous date%: "11-Jun-90 14:41:02" "{Pele:mv:envos}<LispCore>Sources>CMLFLOATARRAY.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLFLOATARRAYCOMS)
+
+(RPAQQ CMLFLOATARRAYCOMS

+       [(DECLARE%: DONTCOPY DOEVAL@COMPILE (FILES (SYSLOAD FROM VALUEOF DIRECTORIES)
+                                                  UNBOXEDOPS FLOAT-ARRAY-SUPPORT))
+        
+        (* ;; "MAPARRAY fns and macros")

+
+        (FNS MAP-ARRAY)
+        (FUNCTIONS MAP-ARRAY-1 MAP-ARRAY-2)
+        (FUNCTIONS REDUCE-ARRAY EVALUATE-POLYNOMIAL FIND-ARRAY-ELEMENT-INDEX)
+        (FUNCTIONS FLATTEN-ARG MAX-ABS MIN-ABS)
+        (FUNCTIONS %%MAP-FLOAT-ARRAY-ABS %%MAP-FLOAT-ARRAY-FLOAT %%MAP-FLOAT-ARRAY-MINUS 
+               %%MAP-FLOAT-ARRAY-NEGATE %%MAP-FLOAT-ARRAY-PLUS %%MAP-FLOAT-ARRAY-QUOTIENT 
+               %%MAP-FLOAT-ARRAY-TIMES %%MAP-FLOAT-ARRAY-TRUNCATE %%REDUCE-FLOAT-ARRAY-MAX 
+               %%REDUCE-FLOAT-ARRAY-MAX-ABS %%REDUCE-FLOAT-ARRAY-MIN %%REDUCE-FLOAT-ARRAY-MIN-ABS 
+               %%REDUCE-FLOAT-ARRAY-PLUS %%REDUCE-FLOAT-ARRAY-TIMES)
+        
+        (* ;; "For convenience")

+
+        (PROP FILETYPE CMLFLOATARRAY)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA MAP-ARRAY])
+(DECLARE%: DONTCOPY DOEVAL@COMPILE 
+
+(FILESLOAD (SYSLOAD FROM VALUEOF DIRECTORIES)
+       UNBOXEDOPS FLOAT-ARRAY-SUPPORT)
+)
+
+
+
+(* ;; "MAPARRAY fns and macros")

+
+(DEFINEQ
+
+(MAP-ARRAY

+  [LAMBDA ARGS                                               (* ; "Edited  9-Apr-87 16:22 by jop")

+
+    (* ;; "First arg, RESULT, may either be an array of the correct type, or a symbol indicating the element-type of the result, or NIL if the map is for effect. Second arg is the mapping functions. Other args are arrays, all of which must have the same number of elements, or non-arrays which will be treated as scalars ")

+
+    (LISP:IF (< ARGS 3)
+           (LISP:ERROR "MAPARRAY takes at least three args"))
+    (LET ((RESULT (ARG ARGS 1))
+          (MAPFN (ARG ARGS 2))
+          (ARRAY1 (ARG ARGS 3))
+          FIRST-ARRAY)
+
+         (* ;; "Arg checking. First-array is the first array map argument")

+
+         (LISP:IF (NOT (TYPEP MAPFN 'LISP:FUNCTION))
+                (LISP:ERROR "Not a function: ~S" MAPFN))
+         (LISP:DO ((I 3 (LISP:1+ I))
+                   MAP-ARG)
+                  ((> I ARGS))
+             (SETQ MAP-ARG (ARG ARGS I))
+             (LISP:WHEN (LISP:ARRAYP MAP-ARG)
+                 (LISP:IF FIRST-ARRAY
+                     (LISP:IF (NOT (EQUAL-DIMENSIONS-P MAP-ARG FIRST-ARRAY))
+                            (LISP:ERROR "Dimensions mismatch" MAP-ARG))
+                     (SETQ FIRST-ARRAY MAP-ARG))))
+
+         (* ;; "Coerce RESULT into an array or NIL")

+
+         (LISP:TYPECASE RESULT
+             (LISP:ARRAY (LISP:IF [NOT (OR (EQUAL-DIMENSIONS-P RESULT FIRST-ARRAY)
+                                           (AND (NULL FIRST-ARRAY)
+                                                (EQ 0 (LISP:ARRAY-RANK RESULT]
+                                (LISP:ERROR "Dimensions mismatch: ~S" RESULT)))
+             ((OR LISP:SYMBOL CONS) (SETQ RESULT (LISP:IF FIRST-ARRAY
+                                                     (LISP:MAKE-ARRAY (LISP:ARRAY-DIMENSIONS 
+                                                                             FIRST-ARRAY)
+                                                            :ELEMENT-TYPE RESULT)
+                                                     (LISP:MAKE-ARRAY NIL :ELEMENT-TYPE RESULT))))
+             (T (OR (NULL RESULT)
+                    (LISP:ERROR "RESULT must be an array, an element type, or NIL: ~S" RESULT))))
+         (LISP:IF FIRST-ARRAY
+             (LISP:IF (AND RESULT (< ARGS 5))
+                 (LISP:ECASE ARGS
+                     (3                                      (* ; 
+
                                                       "Note: in this case (EQ ARRAY1 FIRST-ARRAY)")

+                        (MAP-ARRAY-1
 RESULT MAPFN ARRAY1))
+                     (4 (MAP-ARRAY-2
 RESULT MAPFN ARRAY1 (ARG ARGS 4))))
+                 [LET* ((FLATTENED-RESULT (FLATTEN-ARG
 RESULT))
+                        (SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                        [FLATTENED-ARRAYS (for
 I from
 3 to
 ARGS
+                                             collect
 (FLATTEN-ARG
 (ARG ARGS I]
+                        (ELT-SLICE (LISP:COPY-LIST FLATTENED-ARRAYS))
+                        VALUE)
+                       (LISP:DOTIMES (INDEX SIZE RESULT)
+                           [SETQ VALUE (LISP:APPLY MAPFN (LISP:DO ((%%SUBSLICE ELT-SLICE (CDR 
+                                                                                           %%SUBSLICE
+                                                                                              ))
+                                                                   (%%SUBARRAYS FLATTENED-ARRAYS
+                                                                          (CDR %%SUBARRAYS)))
+                                                                  ((NULL %%SUBARRAYS)
+                                                                   ELT-SLICE)
+                                                             (AND (LISP:ARRAYP (CAR %%SUBARRAYS))
+                                                                  (RPLACA %%SUBSLICE
+                                                                         (LISP:AREF (CAR %%SUBARRAYS)
+                                                                                INDEX))))]
+                           (LISP:IF RESULT
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      VALUE)))])
+             (LISP:IF RESULT
+                 [LISP:SETF (LISP:AREF RESULT)
+                        (LISP:APPLY MAPFN (for
 I from
 3 to
 ARGS
+                                             collect
 (ARG ARGS I]
+                 (LISP:APPLY MAPFN (for
 I from
 3 to
 ARGS collect
 (ARG ARGS I)))))])
+)
+
+(LISP:DEFUN MAP-ARRAY-1
 (RESULT MAPFN ARRAY)
+
+   (* ;; 
+
 "Does something fast for MAPFNS - abs truncate float and EXPONENT. ARRAY is always an array.")

+
+   [LET [(RESULT-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE RESULT)
+                             'LISP:SINGLE-FLOAT))
+         (ARRAY-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                            'LISP:SINGLE-FLOAT]              (* ; "Coerce MAPFN to standard form")

+        (SETQ MAPFN (LISP:TYPECASE MAPFN
+                        (LISP:SYMBOL (CASE MAPFN
+                                         (MINUS '-)
+                                         (FIX 'LISP:TRUNCATE)
+                                         (T MAPFN)))
+                        (COMPILED-CLOSURE (COND
+                                             ((OR (LISP::%%EQCODEP MAPFN '-)
+                                                  (LISP::%%EQCODEP MAPFN 'MINUS))
+                                              '-)
+                                             ((LISP::%%EQCODEP MAPFN 'ABS)
+                                              'ABS)
+                                             ((OR (LISP::%%EQCODEP MAPFN 'FIX)
+                                                  (LISP::%%EQCODEP MAPFN 'LISP:TRUNCATE))
+                                              'LISP:TRUNCATE)
+                                             ((LISP::%%EQCODEP MAPFN 'FLOAT)
+                                              'FLOAT)
+                                             (T MAPFN)))
+                        (T MAPFN)))
+        (COND
+           ((AND (EQ MAPFN '-)
+                 RESULT-FLOAT-P ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-NEGATE
 RESULT ARRAY))
+           ((AND (EQ MAPFN 'ABS)
+                 RESULT-FLOAT-P ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-ABS
 RESULT ARRAY))
+           ((AND (EQ MAPFN 'LISP:TRUNCATE)
+                 ARRAY-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-TRUNCATE
 RESULT ARRAY))
+           ((AND (EQ MAPFN 'FLOAT)
+                 RESULT-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-FLOAT
 RESULT ARRAY))
+           (T (LET ((FLATTENED-RESULT (FLATTEN-ARG
 RESULT))
+                    (FLATTENED-ARRAY (FLATTEN-ARG
 ARRAY)))
+                   (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                        RESULT)
+                       (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                              (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY INDEX))))])
+
+(LISP:DEFUN MAP-ARRAY-2
 (RESULT MAPFN ARRAY-1 ARRAY-2)
+
+   (* ;; "Does something fast for MAPFNS + - * /. At least one of ARRAY-1 and ARRAY-2 is an array")

+
+   [LET [(ARRAYS-FLOAT-P (AND (EQ (LISP:ARRAY-ELEMENT-TYPE RESULT)
+                                  'LISP:SINGLE-FLOAT)
+                              [OR (TYPEP ARRAY-1 '(LISP:ARRAY LISP:SINGLE-FLOAT))
+                                  (TYPEP ARRAY-1 '(OR FLOAT LISP:RATIONAL]
+                              (OR (TYPEP ARRAY-2 '(LISP:ARRAY LISP:SINGLE-FLOAT))
+                                  (TYPEP ARRAY-2 '(OR FLOAT LISP:RATIONAL]
+                                                             (* ; "Coerce MAPFN to standard form")

+        (SETQ MAPFN (LISP:TYPECASE MAPFN
+                        (LISP:SYMBOL (CASE MAPFN
+                                         (PLUS '+)
+                                         (MINUS '-)
+                                         (TIMES 'LISP:*)
+                                         (QUOTIENT '/)
+                                         (T MAPFN)))
+                        (COMPILED-CLOSURE (COND
+                                             ((OR (LISP::%%EQCODEP MAPFN '+)
+                                                  (LISP::%%EQCODEP MAPFN 'PLUS))
+                                              '+)
+                                             ((OR (LISP::%%EQCODEP MAPFN '-)
+                                                  (LISP::%%EQCODEP MAPFN 'MINUS))
+                                              '-)
+                                             ((OR (LISP::%%EQCODEP MAPFN 'LISP:*)
+                                                  (LISP::%%EQCODEP MAPFN 'TIMES))
+                                              'LISP:*)
+                                             ((OR (LISP::%%EQCODEP MAPFN '/)
+                                                  (LISP::%%EQCODEP MAPFN 'QUOTIENT))
+                                              '/)
+                                             (T MAPFN)))
+                        (T MAPFN)))
+        (COND
+           ((AND (EQ MAPFN '+)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-PLUS
 RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN '-)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-MINUS
 RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN 'LISP:*)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-TIMES
 RESULT ARRAY-1 ARRAY-2))
+           ((AND (EQ MAPFN '/)
+                 ARRAYS-FLOAT-P)
+            (%%MAP-FLOAT-ARRAY-QUOTIENT
 RESULT ARRAY-1 ARRAY-2))
+           (T (LET ((FLATTENED-RESULT (FLATTEN-ARG
 RESULT))
+                    (FLATTENED-ARRAY-1 (FLATTEN-ARG
 ARRAY-1))
+                    (FLATTENED-ARRAY-2 (FLATTEN-ARG
 ARRAY-2)))
+                   (LISP:IF (LISP:ARRAYP ARRAY-1)
+                       (LISP:IF (LISP:ARRAYP ARRAY-2)
+                           (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                                RESULT)
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY-1 INDEX)
+                                             (LISP:AREF FLATTENED-ARRAY-2 INDEX))))
+                           (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                                RESULT)
+                               (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                      (LISP:FUNCALL MAPFN (LISP:AREF FLATTENED-ARRAY-1 INDEX)
+                                             FLATTENED-ARRAY-2))))
+                       (LISP:DOTIMES (INDEX (LISP:ARRAY-TOTAL-SIZE RESULT)
+                                            RESULT)
+                           (LISP:SETF (LISP:AREF FLATTENED-RESULT INDEX)
+                                  (LISP:FUNCALL MAPFN FLATTENED-ARRAY-1 (LISP:AREF FLATTENED-ARRAY-2
+                                                                               INDEX)))))])
+
+(LISP:DEFUN REDUCE-ARRAY
 (REDUCTION-FN ARRAY &OPTIONAL (INITIAL-VALUE NIL INITIAL-VALUE-P))
+   (SETQ REDUCTION-FN (LISP:TYPECASE REDUCTION-FN
+                          (LISP:SYMBOL (CASE REDUCTION-FN
+                                           (PLUS '+)
+                                           (TIMES 'LISP:*)
+                                           (T REDUCTION-FN)))
+                          (COMPILED-CLOSURE (COND
+                                               ((OR (LISP::%%EQCODEP REDUCTION-FN '+)
+                                                    (LISP::%%EQCODEP REDUCTION-FN 'PLUS))
+                                                '+)
+                                               ((OR (LISP::%%EQCODEP REDUCTION-FN 'LISP:*)
+                                                    (LISP::%%EQCODEP REDUCTION-FN 'TIMES))
+                                                'LISP:*)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MIN)
+                                                'MIN)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MAX)
+                                                'MAX)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MIN-ABS)
+                                                'MIN-ABS)
+                                               ((LISP::%%EQCODEP REDUCTION-FN 'MAX-ABS)
+                                                'MAX-ABS)
+                                               (T REDUCTION-FN)))
+                          (T REDUCTION-FN)))
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY))
+       (LISP:IF INITIAL-VALUE-P
+           (LISP:FUNCALL REDUCTION-FN INITIAL-VALUE ARRAY)
+           ARRAY)
+       [LET [(SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY))
+             (ARRAY-FLOAT-P (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                                'LISP:SINGLE-FLOAT]
+            (CASE SIZE
+                (0 (LISP:IF INITIAL-VALUE-P
+                       INITIAL-VALUE
+                       (LISP:FUNCALL REDUCTION-FN)))
+                (1 (LISP:IF INITIAL-VALUE-P
+                       (LISP:FUNCALL REDUCTION-FN INITIAL-VALUE (LISP:AREF (FLATTEN-ARG
 ARRAY)
+                                                                       0))
+                       (LISP:AREF (FLATTEN-ARG
 ARRAY)
+                              0)))
+                (T [COND
+                      ((AND (EQ REDUCTION-FN '+)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-PLUS
 ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'LISP:*)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-TIMES
 ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MIN)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MIN
 ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MAX)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MAX
 ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MIN-ABS)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MIN-ABS
 ARRAY INITIAL-VALUE))
+                      ((AND (EQ REDUCTION-FN 'MAX-ABS)
+                            ARRAY-FLOAT-P)
+                       (%%REDUCE-FLOAT-ARRAY-MAX-ABS
 ARRAY INITIAL-VALUE))
+                      (T (LISP:DO* ((FLATTENED-ARRAY (FLATTEN-ARG
 ARRAY))
+                                    (ACCUMULATOR (LISP:IF INITIAL-VALUE-P
+                                                     INITIAL-VALUE
+                                                     (LISP:AREF FLATTENED-ARRAY 0)))
+                                    (INDEX (LISP:IF INITIAL-VALUE-P
+                                               0
+                                               1)
+                                           (LISP:1+ INDEX)))
+                                   ((EQ INDEX SIZE)
+                                    ACCUMULATOR)
+                             (SETQ ACCUMULATOR (LISP:FUNCALL REDUCTION-FN ACCUMULATOR
+                                                      (LISP:AREF FLATTENED-ARRAY INDEX))))]))]))
+
+(LISP:DEFUN EVALUATE-POLYNOMIAL
 (X COEFFICIENTS)
+   (LISP:IF (NOT (LISP:ARRAYP COEFFICIENTS))
+       (LISP:ERROR "Not an array: ~S" COEFFICIENTS)
+       (LISP:IF (EQ (LISP:ARRAY-ELEMENT-TYPE COEFFICIENTS)
+                    'LISP:SINGLE-FLOAT)
+           (%%POLY-EVAL (FLOAT X)
+                  (%%GET-FLOAT-ARRAY-BASE COEFFICIENTS)
+                  (LISP:1- (LISP:ARRAY-TOTAL-SIZE COEFFICIENTS)))
+           (LISP:DO ((FLATTENED-ARRAY (FLATTEN-ARG
 COEFFICIENTS))
+                     (INDEX 1 (LISP:1+ INDEX))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE COEFFICIENTS))
+                     (PRODUCT (LISP:AREF COEFFICIENTS 0)))
+                    ((EQ INDEX SIZE)
+                     PRODUCT)
+               (SETQ PRODUCT (+ (LISP:* X PRODUCT)
+                                (LISP:AREF COEFFICIENTS INDEX)))))))
+
+(LISP:DEFUN FIND-ARRAY-ELEMENT-INDEX
 (ELEMENT ARRAY)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY))
+       (LISP:ERROR "Not an array: ~S" ARRAY)
+       (LISP:IF (EQ (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                    'LISP:SINGLE-FLOAT)
+           (LISP:DO ((BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                           (\ADDBASE BASE 2))
+                     (INDEX 0 (LISP:1+ INDEX))
+                     (F-ELEMENT (FLOAT ELEMENT))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                    ((EQ INDEX SIZE)
+                     NIL)
+               (DECLARE
 (TYPE FLOAT F-ELEMENT))
+               (LISP:IF (UFEQP F-ELEMENT (\GETBASEFLOATP BASE 0))
+                      (RETURN INDEX)))
+           (LISP:DO ((FLATTENED-ARRAY (FLATTEN-ARG
 ARRAY))
+                     (INDEX 0 (LISP:1+ INDEX))
+                     (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                    ((EQ INDEX SIZE)
+                     NIL)
+               (LISP:IF (EQL ELEMENT (LISP:AREF FLATTENED-ARRAY INDEX))
+                      (RETURN INDEX))))))
+
+(LISP:DEFUN FLATTEN-ARG
 (ARG)
+   (LISP:IF (OR (NOT (LISP:ARRAYP ARG))
+                (EQ 1 (LISP:ARRAY-RANK ARG)))
+       ARG
+       (LISP:MAKE-ARRAY (LISP:ARRAY-TOTAL-SIZE ARG)
+              :ELEMENT-TYPE
+              (LISP:ARRAY-ELEMENT-TYPE ARG)
+              :DISPLACED-TO ARG)))
+
+(LISP:DEFUN MAX-ABS
 (X Y)
+   (LISP:IF (> (ABS X)
+               (ABS Y))
+       X
+       Y))
+
+(LISP:DEFUN MIN-ABS
 (X Y)
+   (LISP:IF (< (ABS X)
+               (ABS Y))
+       X
+       Y))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-ABS
 (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                    (\ADDBASE RESULT-BASE 2))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (\PUTBASEFLOATP RESULT-BASE 0 (UFABS (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-FLOAT
 (RESULT ARRAY)
+   (LET ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT)))
+        (LISP:IF (EQUAL (LISP:ARRAY-ELEMENT-TYPE ARRAY)
+                        '(LISP:UNSIGNED-BYTE 16))
+            (%%BLKSMALLP2FLOAT (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                   (%%GET-FLOAT-ARRAY-BASE RESULT)
+                   SIZE)
+            (LISP:DO ((RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                             (\ADDBASE RESULT-BASE 2))
+                      (INDEX 0 (LISP:1+ INDEX)))
+                     ((EQ INDEX SIZE))
+                (\PUTBASEFLOATP RESULT-BASE 0 (FLOAT (LISP:AREF ARRAY INDEX)))))
+        RESULT))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-MINUS
 (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (LISP:ARRAYP ARRAY-1)
+       (LISP:IF (LISP:ARRAYP ARRAY-2)
+           (%%BLKFDIFF (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                  (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                  (%%GET-FLOAT-ARRAY-BASE RESULT)
+                  (LISP:ARRAY-TOTAL-SIZE RESULT))
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (SCALAR (FLOAT ARRAY-2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (DECLARE
 (TYPE FLOATP SCALAR))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    SCALAR))))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (SCALAR (FLOAT ARRAY-1))
+                 (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                        (\ADDBASE ARRAY-2-BASE 2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE
 (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FDIFFERENCE SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0)))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-NEGATE
 (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                    (\ADDBASE RESULT-BASE 2))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (\PUTBASEFLOATP RESULT-BASE 0 (UFMINUS (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-PLUS
 (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY-1))
+          (LISP:ROTATEF ARRAY-1 ARRAY-2))                    (* ; "addition is commutative")

+   (LISP:IF (LISP:ARRAYP ARRAY-2)
+       (%%BLKFPLUS (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+              (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+              (%%GET-FLOAT-ARRAY-BASE RESULT)
+              (LISP:ARRAY-TOTAL-SIZE RESULT))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                        (\ADDBASE ARRAY-1-BASE 2))
+                 (SCALAR (FLOAT ARRAY-2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE
 (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FPLUS (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                SCALAR))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-QUOTIENT
 (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (LISP:ARRAYP ARRAY-1)
+       (LISP:IF (LISP:ARRAYP ARRAY-2)
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    (\GETBASEFLOATP ARRAY-2-BASE 0))))
+           (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                     (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                            (\ADDBASE RESULT-BASE 2))
+                     (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                            (\ADDBASE ARRAY-1-BASE 2))
+                     (SCALAR (FLOAT ARRAY-2))
+                     (INDEX 0 (LISP:1+ INDEX)))
+                    ((EQ INDEX SIZE))
+               (DECLARE
 (TYPE FLOATP SCALAR))
+               (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                    SCALAR))))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (SCALAR (FLOAT ARRAY-1))
+                 (ARRAY-2-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+                        (\ADDBASE ARRAY-2-BASE 2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE
 (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FQUOTIENT SCALAR (\GETBASEFLOATP ARRAY-2-BASE 0)))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-TIMES
 (RESULT ARRAY-1 ARRAY-2)
+   (LISP:IF (NOT (LISP:ARRAYP ARRAY-1))
+          (LISP:ROTATEF ARRAY-1 ARRAY-2))                    (* ; "Multiplication is commutative")

+   (LISP:IF (LISP:ARRAYP ARRAY-2)
+       (%%BLKFTIMES (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+              (%%GET-FLOAT-ARRAY-BASE ARRAY-2)
+              (%%GET-FLOAT-ARRAY-BASE RESULT)
+              (LISP:ARRAY-TOTAL-SIZE RESULT))
+       (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+                 (RESULT-BASE (%%GET-FLOAT-ARRAY-BASE RESULT)
+                        (\ADDBASE RESULT-BASE 2))
+                 (ARRAY-1-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY-1)
+                        (\ADDBASE ARRAY-1-BASE 2))
+                 (SCALAR (FLOAT ARRAY-2))
+                 (INDEX 0 (LISP:1+ INDEX)))
+                ((EQ INDEX SIZE))
+           (DECLARE
 (TYPE FLOATP SCALAR))
+           (\PUTBASEFLOATP RESULT-BASE 0 (FTIMES (\GETBASEFLOATP ARRAY-1-BASE 0)
+                                                SCALAR))))
+   RESULT)
+
+(LISP:DEFUN %%MAP-FLOAT-ARRAY-TRUNCATE
 (RESULT ARRAY)
+   (LISP:DO ((SIZE (LISP:ARRAY-TOTAL-SIZE RESULT))
+             (ARRAY-BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                    (\ADDBASE ARRAY-BASE 2))
+             (INDEX 0 (LISP:1+ INDEX)))
+            ((EQ INDEX SIZE)
+             RESULT)
+       (LISP:SETF (LISP:AREF RESULT INDEX)
+              (UFIX (\GETBASEFLOATP ARRAY-BASE 0)))))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MAX
 (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFMAX (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MAX INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MAX-ABS
 (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFABSMAX (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MAX-ABS
 INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MIN
 (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFMIN (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MIN INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-MIN-ABS
 (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (LISP:AREF ARRAY (%%BLKFABSMIN (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                                         0
+                                         (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (MIN-ABS
 INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-PLUS
 (ARRAY INITIAL-VALUE)
+   (LET [(RESULT (%%POLY-EVAL 1.0 (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                        (LISP:1- (LISP:ARRAY-TOTAL-SIZE ARRAY]
+        (LISP:IF INITIAL-VALUE
+            (+ INITIAL-VALUE RESULT)
+            RESULT)))
+
+(LISP:DEFUN %%REDUCE-FLOAT-ARRAY-TIMES
 (ARRAY INITIAL-VALUE)
+   (LET ((TOTAL 1.0))
+        (DECLARE
 (TYPE FLOAT TOTAL))
+        (LISP:DO ((I 0 (LISP:1+ I))
+                  (BASE (%%GET-FLOAT-ARRAY-BASE ARRAY)
+                        (\ADDBASE BASE 2))
+                  (SIZE (LISP:ARRAY-TOTAL-SIZE ARRAY)))
+                 ((EQ I SIZE)
+                  TOTAL)
+            (SETQ TOTAL (LISP:* TOTAL (\GETBASEFLOATP BASE 0))))
+        (LISP:IF INITIAL-VALUE
+            (LISP:* INITIAL-VALUE TOTAL)
+            TOTAL)))
+
+
+
+(* ;; "For convenience")

+
+
+(PUTPROPS CMLFLOATARRAY
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 MAP-ARRAY)
+)
+(PUTPROPS CMLFLOATARRAY COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1897 6534 (MAP-ARRAY 1907 . 6532)))))
+STOP

CLTL2/CMLHASH

@@ -0,0 +1,361 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+
(IL:FILECREATED " 2-Apr-92 13:37:38" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLHASH.;6|
 16577  
+
+      IL:|changes| IL:|to:|  (IL:FUNCTIONS CL:WITH-HASH-TABLE-ITERATOR)
+                             (IL:VARS IL:CMLHASHCOMS)
+
+      IL:|previous| IL:|date:| " 1-Apr-92 13:16:01" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLHASH.;4|
+)
+
+
+; Copyright (c) 1985, 1986, 1987, 1989, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLHASHCOMS)
+
+(IL:RPAQQ IL:CMLHASHCOMS
 (
+                              (IL:* IL:|;;| "External interface")

+
+                              (IL:FUNCTIONS MAKE-HASH-TABLE GETHASH MAPHASH HASH-TABLE-COUNT 
+                                     HASH-TABLE-P SXHASH)
+                              (XCL:OPTIMIZERS GETHASH HASH-TABLE-COUNT HASH-TABLE-P)
+                              (IL:SETFS GETHASH)
+                              (IL:FUNCTIONS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-REHASH-THRESHOLD
+                                     CL:HASH-TABLE-SIZE CL:HASH-TABLE-TEST 
+                                     CL:WITH-HASH-TABLE-ITERATOR)
+                              (XCL:OPTIMIZERS CL:HASH-TABLE-REHASH-SIZE CL:HASH-TABLE-SIZE 
+                                     CL:HASH-TABLE-TEST)
+                              
+                              (IL:* IL:|;;| "Internal interface")

+
+                              (IL:FUNCTIONS EQLHASHBITSFN SXHASH-PATHNAME)
+                              (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:VARIABLES SXHASH-MAX)
+                                     (IL:FUNCTIONS SXHASH-LIST SXHASH-STRING SXHASH-BIT-VECTOR 
+                                            SXHASH-ROT))
+                              
+                              (IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)")

+
+                              (IL:FNS SXHASH-UFN EQLHASHBITSFN-UFN %SXHASH)
+                              (IL:FUNCTIONS CL::%SXHASH-EQUALP SXHASH-EQUALP-STRING)
+                              (XCL:OPTIMIZERS SXHASH EQLHASHBITSFN)
+                              (XCL:OPTIMIZERS IL:STRINGHASHBITS IL:STRING-EQUAL-HASHBITS)
+                              (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                                     IL:CMLHASH)))
+
+
+
+(IL:* IL:|;;| "External interface")

+
+
+(DEFUN MAKE-HASH-TABLE
 (&KEY (TEST 'EQL)
+                                 (SIZE 65)
+                                 REHASH-SIZE REHASH-THRESHOLD)

+                                                       (IL:* IL:\; "Edited 23-Mar-92 16:27 by jrb:")

+
+   (IL:* IL:|;;| "Creates and returns a hash table.  See manual for details.")

+
+   (IF (NOT (SYMBOLP TEST))
+       (COND
+          ((%EQCODEP TEST 'EQ)
+           (SETQ TEST 'EQ))
+          ((%EQCODEP TEST 'EQL)
+           (SETQ TEST 'EQL))
+          ((%EQCODEP TEST 'EQUAL)
+           (SETQ TEST 'EQUAL))
+          ((%EQCODEP TEST 'EQUALP)
+           (SETQ TEST 'EQUALP))))
+   (ECASE TEST
+       (EQ (IL:HASHARRAY SIZE REHASH-SIZE))
+       (EQL (IL:HASHARRAY SIZE REHASH-SIZE 'EQLHASHBITSFN 'EQL))
+       (EQUAL (IL:HASHARRAY SIZE REHASH-SIZE 'SXHASH 'EQUAL))
+       (EQUALP 
+
+          (IL:* IL:|;;| "NOTE: CL::%SXHASH-EQUALP has no microcode/C support and is hence SLOW")

+
+          (IL:HASHARRAY SIZE REHASH-SIZE 'CL::%SXHASH-EQUALP 'EQUALP))))
+
+(DEFUN GETHASH
 (KEY HASHTABLE &OPTIONAL DEFAULT)
+   (IL:GETHASH KEY HASHTABLE DEFAULT T))
+
+(DEFUN MAPHASH
 (FN HASH-TABLE)
+   "Call function with each key/value pair in the hash-table"
+   (IL:MAPHASH HASH-TABLE #'(LAMBDA (VALUE KEY)
+                                   (FUNCALL FN KEY VALUE)))
+   NIL)
+
+(DEFUN HASH-TABLE-COUNT
 (HASH-TABLE)
+   (IL:HARRAYPROP HASH-TABLE 'IL:NUMKEYS))
+
+(DEFUN HASH-TABLE-P
 (OBJECT)
+   (IL:TYPENAMEP OBJECT 'IL:HARRAYP))
+
+(DEFUN SXHASH
 (OBJECT)
+   (IL:MISCN SXHASH OBJECT))
+
+(XCL:DEFOPTIMIZER GETHASH
 (KEY HASHTABLE &OPTIONAL DEFAULT XCL:&CONTEXT CONTEXT)
+                              (IF (EQ 1 (COMPILER:CONTEXT-VALUES-USED CONTEXT))
+                                  (IF DEFAULT
+                                      `(IL:GETHASH ,KEY ,HASHTABLE ,DEFAULT)
+                                      `(IL:GETHASH ,KEY ,HASHTABLE))
+                                  'COMPILER:PASS))
+
+(XCL:DEFOPTIMIZER HASH-TABLE-COUNT
 (HASH-TABLE)
+                                       `(IL:HARRAYPROP ,HASH-TABLE 'IL:NUMKEYS))
+
+(XCL:DEFOPTIMIZER HASH-TABLE-P
 (OBJECT)
+                                   `(IL:TYPENAMEP ,OBJECT 'IL:HARRAYP))
+
+(DEFSETF GETHASH
 PUTHASH)
+
+(DEFUN CL:HASH-TABLE-REHASH-SIZE
 (HASH-TABLE)
+   (IL:HARRAYPROP HASH-TABLE 'IL:OVERFLOW))
+
+(DEFUN CL:HASH-TABLE-REHASH-THRESHOLD
 (HASH-TABLE)
+   1)
+
+(DEFUN CL:HASH-TABLE-SIZE
 (HASH-TABLE)
+   (IL:HARRAYSIZE HASH-TABLE))
+
+(DEFUN CL:HASH-TABLE-TEST
 (HASH-TABLE)
         (IL:* IL:\; "Edited 22-Mar-92 20:47 by jrb:")

+   (LET ((CL::TEST (IL:HARRAYPROP HASH-TABLE 'IL:EQUIVFN)))
+        (CASE CL::TEST
+            ((NIL) 'EQ)
+            (T CL::TEST))))
+
+(DEFMACRO CL:WITH-HASH-TABLE-ITERATOR
 ((CL::MNAME HASH-TABLE)
+                                           &REST CL::FORMS)
+   (LET ((IL:HA (GENSYM))
+         (IL:LASTSLOT (GENSYM))
+         (IL:NULLVALUE (GENSYM))
+         (IL:SLOT (GENSYM))
+         (IL:V (GENSYM)))
+
+        (IL:* IL:|;;| "The code below is actually this stuff, macroexpanded to remove references to the IL:HARRAYP record and all the grossly internal stuff in it, which aren't normally in the sysout")

+
+        (IL:* IL:|;;| "`(LET* ((,IL:HA (IL:\\\\DTEST ,HASH-TABLE 'IL:HARRAYP)) (,IL:LASTSLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| (IL:\\\\HASHSLOT (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA) (IL:|fetch| (IL:HARRAYP IL:LASTINDEX) IL:|of| ,IL:HA)))) (,IL:NULLVALUE IL:\\\\HASH.NULL.VALUE) ,IL:SLOT ,IL:V) (FLET ((,MNAME ( (IL:|until| (EQ (IL:SETQ ,IL:SLOT (IF ,IL:SLOT (IL:|fetch| (IL:HASHSLOT IL:NEXTSLOT) IL:|of| ,IL:SLOT) (IL:|fetch| IL:HARRAYPBASE IL:|of| ,IL:HA))) ,IL:LASTSLOT) IL:|when| (IL:SETQ ,IL:V (IL:|fetch| (IL:HASHSLOT IL:VALUE) IL:|of| ,IL:SLOT)) IL:|do| (RETURN (VALUES T (IL:|fetch| (IL:HASHSLOT IL:KEY) IL:|of| ,IL:SLOT) (AND (IL:NEQ ,IL:V ,IL:NULLVALUE) ,IL:V))) IL:|finally| (RETURN NIL)))) ,@FORMS))")

+
+        `(LET* ((,IL:HA (IL:\\DTEST ,HASH-TABLE 'IL:HARRAYP))
+                (,IL:LASTSLOT (IL:\\ADDBASE (IL:\\ADDBASE (IL:FETCHFIELD '(IL:HARRAYP 2 IL:POINTER)
+                                                                 ,IL:HA)
+                                                   (IL:LLSH (IL:FETCHFIELD '(IL:HARRAYP 1
+                                                                                   (IL:BITS . 15))
+                                                                   ,IL:HA)
+                                                          2))
+                                     4))
+                (,IL:NULLVALUE IL:\\HASH.NULL.VALUE)
+                ,IL:SLOT
+                ,IL:V)
+               (FLET ((,CL::MNAME NIL (IL:|until|
 (EQ (IL:SETQ ,IL:SLOT
+                                                           (IF ,IL:SLOT
+                                                               (IL:\\ADDBASE ,IL:SLOT 4)
+                                                               (IL:FETCHFIELD '(IL:HARRAYP 2 
+                                                                                      IL:POINTER)
+                                                                      ,IL:HA)))
+                                                          ,IL:LASTSLOT)
+                                         IL:|when|
 (IL:SETQ ,IL:V (IL:FETCHFIELD
+                                                                       '(NIL 2 IL:POINTER)
+                                                                       ,IL:SLOT))
+                                         IL:|do|
 (RETURN (VALUES T (IL:FETCHFIELD
+                                                                        '(NIL 0 IL:POINTER)
+                                                                        ,IL:SLOT)
+                                                                    (AND (IL:NEQ ,IL:V ,IL:NULLVALUE)
+                                                                         ,IL:V)))
+                                         IL:|finally|
 (RETURN NIL))))
+                     ,@CL::FORMS))))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-REHASH-SIZE
 (HASH-TABLE)
+                                                `(IL:HARRAYPROP ,HASH-TABLE 'IL:OVERFLOW))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-SIZE
 (HASH-TABLE)
+                                         `(IL:HARRAYSIZE ,HASH-TABLE))
+
+(XCL:DEFOPTIMIZER CL:HASH-TABLE-TEST
 (HASH-TABLE)
+                                         `(LET ((CL::TEST (IL:HARRAYPROP ,HASH-TABLE 'IL:EQUIVFN)))
+                                               (CASE CL::TEST
+                                                   ((NIL) 'EQ)
+                                                   (T CL::TEST))))
+
+
+
+(IL:* IL:|;;| "Internal interface")

+
+
+(DEFUN EQLHASHBITSFN
 (OBJ)
+   (IL:MISCN EQLHASHBITSFN OBJ))
+
+(DEFUN SXHASH-PATHNAME
 (PATHNAME)
+   (LET ((HASH (SXHASH-ROT
 (LOGXOR (%SXHASH
 (IL:%PATHNAME-HOST PATHNAME))
+                                      (%SXHASH
 (IL:%PATHNAME-DEVICE PATHNAME))))))
+        (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (%SXHASH
 (IL:%PATHNAME-TYPE PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (%SXHASH
 (IL:%PATHNAME-VERSION PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (%SXHASH
 (IL:%PATHNAME-DIRECTORY PATHNAME)))))
+        (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (%SXHASH
 (IL:%PATHNAME-NAME PATHNAME)))))))
+(IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE 
+
+(DEFCONSTANT SXHASH-MAX
 13)
+
+
+(DEFMACRO SXHASH-LIST
 (LIST)
+   `(DO ((LIST ,LIST (CDR LIST))
+         (INDEX 0 (1+ INDEX))
+         (HASH 0))
+        ((OR (NOT (CONSP LIST))
+             (EQ INDEX SXHASH-MAX))
+         HASH)
+      (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (%SXHASH
 (CAR LIST)))))))
+
+(DEFMACRO SXHASH-STRING
 (STRING)                         (IL:* IL:\; 
+
                                                         "Returns hash value for a general string.")

+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,STRING)
+                      SXHASH-MAX))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+
+      (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.")

+
+      (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (CHAR-INT (AREF ,STRING I)))))))
+
+(DEFMACRO SXHASH-BIT-VECTOR
 (BIT-VECTOR)
+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,BIT-VECTOR)
+                      16))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+      (SETQ HASH (+ (ASH HASH 1)
+                    (AREF ,BIT-VECTOR I)))))
+
+(DEFMACRO SXHASH-ROT
 (X)
+   `(LET ((X ,X))
+         (DPB X (BYTE 9 7)
+              (LDB (BYTE 7 9)
+                   X))))
+)
+
+
+
+(IL:* IL:|;;| "UFN for the SXHASH opcode (a MISCN)")

+
+(IL:DEFINEQ
+
+(SXHASH-UFN

+  (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR)
      (IL:* IL:\; "Edited 23-Feb-89 19:45 by jds")

+
+    (IL:* IL:|;;| 
+
  "This is the UFN for the CL:SXHASH MISCN sub-opcode.  That MISCN is being implemented on Suns.")

+
+    (%SXHASH
 (IL:\\GETBASEPTR IL:ARG-PTR 0))))
+
+(EQLHASHBITSFN-UFN

+  (IL:LAMBDA (IL:INDEX IL:ARGCOUNT IL:ARG-PTR)
      (IL:* IL:\; "Edited 23-Feb-89 18:10 by jds")

+    (LET ((OBJ (IL:\\GETBASEPTR IL:ARG-PTR 0)))
+         (TYPECASE OBJ
+             (CHARACTER (CHAR-INT OBJ))
+             (INTEGER (LOGAND OBJ 65535))
+             (FLOAT (LOGXOR (IL:|fetch|
 (IL:FLOATP IL:HIWORD) IL:|of|
 OBJ)
+                           (IL:|fetch|
 (IL:FLOATP IL:LOWORD) IL:|of|
 OBJ)))
+             (RATIO (LOGXOR (EQLHASHBITSFN (NUMERATOR OBJ))
+                           (EQLHASHBITSFN (DENOMINATOR OBJ))))
+             (COMPLEX (LOGXOR (EQLHASHBITSFN (REALPART OBJ))
+                             (EQLHASHBITSFN (IMAGPART OBJ))))
+             (T (IL:\\EQHASHINGBITS OBJ))))))
+
+(%SXHASH

+  (IL:LAMBDA (OBJECT)
                               (IL:* IL:\; "Edited 23-Feb-89 19:42 by jds")

+    (COND
+       ((SYMBOLP OBJECT)
+        (IL:\\EQHASHINGBITS OBJECT))
+       ((LISTP OBJECT)
+        (SXHASH-LIST OBJECT))
+       ((NUMBERP OBJECT)
+        (TYPECASE OBJECT
+            (INTEGER (LOGAND OBJECT MOST-POSITIVE-FIXNUM))
+            (FLOAT (LOGXOR (IL:|fetch|
 (IL:FLOATP IL:HIWORD) IL:|of|
 OBJECT)
+                          (IL:|fetch|
 (IL:FLOATP IL:LOWORD) IL:|of|
 OBJECT)))
+            (RATIO (LOGXOR (%SXHASH
 (NUMERATOR OBJECT))
+                          (%SXHASH
 (DENOMINATOR OBJECT))))
+            (COMPLEX (LOGXOR (%SXHASH
 (REALPART OBJECT))
+                            (%SXHASH
 (IMAGPART OBJECT))))))
+       ((STRINGP OBJECT)
+        (SXHASH-STRING OBJECT))
+       ((BIT-VECTOR-P OBJECT)
+        (SXHASH-BIT-VECTOR OBJECT))
+       ((PATHNAMEP OBJECT)
+        (SXHASH-PATHNAME OBJECT))
+       (T (IL:\\EQHASHINGBITS OBJECT)))))
+)
+
+(DEFUN CL::%SXHASH-EQUALP
 (CL::OBJECT)
         (IL:* IL:\; "Edited 23-Mar-92 16:17 by jrb:")

+   (COND
+      ((SYMBOLP CL::OBJECT)
+       (IL:\\EQHASHINGBITS CL::OBJECT))
+      ((LISTP CL::OBJECT)
+       (SXHASH-LIST
 CL::OBJECT))
+      ((NUMBERP CL::OBJECT)
+
+       (IL:* IL:|;;| "Hacks for numbers for hash key purposes:")

+
+       (IL:* IL:|;;| "FLOATs that can be coerced to integer are")

+
+       (IL:* IL:|;;| "RATIOs are coerecd to floats (it would be better to coerce non-integral FLOATs to RATIOs, but a real pain in the ass; this is probably good enough...)")

+
+       (TYPECASE CL::OBJECT
+           (INTEGER (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM))
+           (FLOAT (IF (= CL::OBJECT (FLOOR CL::OBJECT))
+                      (MULTIPLE-VALUE-BIND (CL::MANT EXP CL::SIGN)
+                             (INTEGER-DECODE-FLOAT CL::OBJECT)
+                             (SETQ CL::OBJECT (ASH CL::MANT EXP))
+                             (WHEN (MINUSP CL::SIGN)
+                                 (SETQ CL::OBJECT (IL:IMINUS CL::OBJECT)))
+                             (LOGAND CL::OBJECT MOST-POSITIVE-FIXNUM))
+                      (LOGXOR (IL:|fetch|
 (IL:FLOATP IL:HIWORD) IL:|of|
 CL::OBJECT)
+                             (IL:|fetch|
 (IL:FLOATP IL:LOWORD) IL:|of|
 CL::OBJECT))))
+           (RATIO (LET ((CL::F (COERCE CL::OBJECT 'FLOAT)))
+                       (LOGXOR (IL:|fetch|
 (IL:FLOATP IL:HIWORD) IL:|of|
 CL::F)
+                              (IL:|fetch|
 (IL:FLOATP IL:LOWORD) IL:|of|
 CL::F))))
+           (COMPLEX (LOGXOR (%SXHASH
 (REALPART CL::OBJECT))
+                           (%SXHASH
 (IMAGPART CL::OBJECT))))))
+      ((STRINGP CL::OBJECT)
+       (SXHASH-EQUALP-STRING
 CL::OBJECT))
+      ((BIT-VECTOR-P CL::OBJECT)
+       (SXHASH-BIT-VECTOR
 CL::OBJECT))
+      ((PATHNAMEP CL::OBJECT)
+       (SXHASH-PATHNAME
 CL::OBJECT))
+      (T (IL:\\EQHASHINGBITS CL::OBJECT))))
+
+(DEFMACRO SXHASH-EQUALP-STRING
 (STRING)
+
+   (IL:* IL:|;;| "Returns EQUALP hash value for a string")

+
+   `(DO ((I 0 (1+ I))
+         (LENGTH (MIN (LENGTH ,STRING)
+                      SXHASH-MAX))
+         (HASH 0))
+        ((EQ I LENGTH)
+         HASH)
+
+      (IL:* IL:|;;| "the spice code had a fairly general \"rotate X within integerlength of most-positive-fixnum bits, but (a) it was slow and (b) it was buggy anyway, since it assumed that most-positive-fixnum was 1 less than a power of two.")

+
+      (SETQ HASH (SXHASH-ROT
 (LOGXOR HASH (IL:%CHAR-UPCASE-CODE (CHAR-CODE (AREF ,STRING I))))))))
+
+(XCL:DEFOPTIMIZER SXHASH
 (OBJECT)
+                             `(IL:MISCN SXHASH ,OBJECT))
+
+(XCL:DEFOPTIMIZER EQLHASHBITSFN
 (OBJECT)
+                                    `(IL:MISCN EQLHASHBITSFN ,OBJECT))
+
+(XCL:DEFOPTIMIZER IL:STRINGHASHBITS
 (STRING)
+                                        `(IL:MISCN IL:STRINGHASHBITS ,STRING))
+
+(XCL:DEFOPTIMIZER IL:STRING-EQUAL-HASHBITS
 (STRING)
+                                               `(IL:MISCN IL:STRING-EQUAL-HASHBITS ,STRING))
+
+(IL:PUTPROPS IL:CMLHASH IL:FILETYPE
 COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLHASH IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:CMLHASH IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1989 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (11187 13240 (SXHASH-UFN 11200 . 11499) (EQLHASHBITSFN-UFN 11501 . 12240) (%SXHASH 
+12242 . 13238)))))
+IL:STOP

CLTL2/CMLLOAD

@@ -0,0 +1,128 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "18-Oct-93 14:18:07" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLLOAD.;2"
 6602   
+
+      |previous| |date:| "15-Dec-92 21:27:17" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLLOAD.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLLOADCOMS)
+
+(RPAQQ CMLLOADCOMS
 ((VARIABLES LISP:*LOAD-PRINT* *LOAD-VERBOSE* LISP:*LOAD-PATHNAME* 
+                               LISP:*LOAD-TRUENAME* XCL::*DEFAULT-SOURCE-IO-PACKAGE*)
+                        (FUNCTIONS LISP::DEFAULT-IO-PACKAGE LISP:LOAD LISP::\\OPENSTREAM-WITH-DEFAULT
+                               )
+                        (FNS \\CML-LOAD)
+                        (PROP FILETYPE CMLLOAD)))
+
+(LISP:DEFVAR LISP:*LOAD-PRINT*
 NIL
+   "Default value for :PRINT in LOAD")
+
+(LISP:DEFVAR *LOAD-VERBOSE*
 T
+   "Default for VERBOSE keyword to LOAD.")
+
+(LISP:DEFVAR LISP:*LOAD-PATHNAME*
 NIL
+   "LOAD binds this to the pathname of the file being loaded")
+
+(LISP:DEFVAR LISP:*LOAD-TRUENAME*
 NIL
+   "LOAD binds this to the truename of the file being loaded")
+
+(LISP:DEFVAR XCL::*DEFAULT-SOURCE-IO-PACKAGE*
 (LISP:FIND-PACKAGE "CL-USER"))
+
+(LISP:DEFUN LISP::DEFAULT-IO-PACKAGE
 (LISP::P)           (* \; "Edited 15-Dec-92 16:06 by jrb:")

+
+   (* |;;| "P is the argument given to the :PACKAGE keyword for any of the functions that get their package defaulted (CL:LOAD, CL:COMPILE-FILE).  The intent is that if P is supplied it is an absolute override; if not we fall back on CLtL2 if XCL:*CLTL2-PEDANTIC* is on; if that doesn't work we try XCL::*DEFAULT-SOURCE-IO-PACKAGE* and we punt if THAT loses.")

+
+   (COND
+      ((NULL LISP::P)
+       (COND
+          (*CLTL2-PEDANTIC* *PACKAGE*)
+          ((LISP:FIND-PACKAGE XCL::*DEFAULT-SOURCE-IO-PACKAGE*))
+          (T (LISP:CERROR "Use current *PACKAGE*" 
+                    "The value of XCL::*DEFAULT-SOURCE-IO-PACKAGE*, ~s, does not name a package" 
+                    XCL::*DEFAULT-SOURCE-IO-PACKAGE*)
+             *PACKAGE*)))
+      ((LISP:FIND-PACKAGE LISP::P))
+      (T (LISP:CERROR "Use current *PACKAGE*" "~s does not name a package" LISP::P)
+         *PACKAGE*)))
+
+(LISP:DEFUN LISP:LOAD
 (FILENAME &KEY ((:VERBOSE *LOAD-VERBOSE*)
+                                          *LOAD-VERBOSE*)
+                                 ((:PRINT LISP:*LOAD-PRINT*)
+                                  LISP:*LOAD-PRINT*)
+                                 (IF-DOES-NOT-EXIST :ERROR)
+                                 (LOADFLG NIL)
+                                 (PACKAGE NIL))            (* \; "Edited 15-Dec-92 16:06 by jrb:")

+   "Loads the file named by Filename into the Lisp environment."
+   (LET* ((LISP:*LOAD-PATHNAME* (LISP:IF (STREAMP FILENAME)
+                                    (IGNORE-ERRORS (PATHNAME FILENAME))
+
+                                 (* |;;| "If the current connected directory is \"{DSK}<tmp>\", (CL:LOAD \"{CORE}FOO\") should load \"{CORE}FOO\" rather than \"{CORE}<tmp>FOO\".  Thus we call MERGE-PATHNAMES iff HOST field is not specified in FILENAME. ")

+
+                                    (LISP:IF (LISP:IF (LISP:PATHNAMEP FILENAME)
+                                                 (LISP:PATHNAME-HOST FILENAME)
+                                                 (FILENAMEFIELD FILENAME 'HOST))
+                                        (PATHNAME FILENAME)
+                                        (LISP:MERGE-PATHNAMES (PATHNAME FILENAME)
+                                               *DEFAULT-PATHNAME-DEFAULTS*))))
+          (LISP:*LOAD-TRUENAME* (AND LISP:*LOAD-PATHNAME* (LISP:TRUENAME LISP:*LOAD-PATHNAME*)))
+          (STREAM (OR (STREAMP FILENAME)
+                      (|if|
 (NULL IF-DOES-NOT-EXIST)
+                          |then|
 (CONDITION-CASE (OPENSTREAM LISP:*LOAD-PATHNAME* 'INPUT
+                                                            'OLD LOADPARAMETERS)
+                                            (XCL:FILE-NOT-FOUND NIL 
+
+                                                   (* |;;| 
+
                              "Spec says return NIL if file not found and IF-DOES-NOT-EXIST is NIL")

+
+                                                   (LISP:RETURN-FROM LISP:LOAD NIL)))
+                        |else|
 (OPENSTREAM LISP:*LOAD-PATHNAME* 'INPUT 'OLD LOADPARAMETERS)))))
+         (LISP:UNWIND-PROTECT
+             (\\LOAD-STREAM STREAM (LISP:INTERN (STRING LOADFLG)
+                                          (LISP:FIND-PACKAGE "INTERLISP"))
+                    LISP:*LOAD-PRINT*
+                    (AND *LOAD-VERBOSE* *TERMINAL-IO*)
+                    PACKAGE)
+             (LISP:CLOSE STREAM))))
+
+(LISP:DEFUN LISP::\\OPENSTREAM-WITH-DEFAULT
 (LISP::FILENAME)
+   (DECLARE
 (LISP:SPECIAL LOADPARAMATERS))
+
+   (* |;;| "If the current connected directory is \"{DSK}<tmp>\", (CL:LOAD \"{CORE}FOO\") should load \"{CORE}FOO\" rather than \"{CORE}<tmp>FOO\".  Thus we call MERGE-PATHNAMES iff HOST field is not specified in FILENAME. ")

+
+   (LISP:IF (NULL (LISP:IF (LISP:PATHNAMEP LISP::FILENAME)
+                      (LISP:PATHNAME-HOST LISP::FILENAME)
+                      (FILENAMEFIELD LISP::FILENAME 'HOST)))
+       (OPENSTREAM (LISP:MERGE-PATHNAMES (PATHNAME LISP::FILENAME)
+                          *DEFAULT-PATHNAME-DEFAULTS*)
+              'INPUT
+              'OLD LOADPARAMETERS)
+       (OPENSTREAM LISP::FILENAME 'INPUT 'OLD LOADPARAMETERS)))
+(DEFINEQ
+
+(\\CML-LOAD

+  (LAMBDA (STREAM PRINTFLG LOAD-VERBOSE-STREAM PACKAGE)      (* \; "Edited  1-Aug-91 10:57 by jrb:")

+
+    (* |;;| "Loads a \"Common Lisp file\" a la CL:LOAD.  Currently only do this if file starts with semi-colon.  PACKAGE overrides the default (USER).")

+
+    (LET ((*PACKAGE* PACKAGE)
+          (*READTABLE* CMLRDTBL)
+          (FULL (FULLNAME STREAM))
+          (EOF-MARK "EOF")
+          EXPR)
+         (|until|
 (EQ EOF-MARK (SETQ EXPR (LISP:READ STREAM NIL EOF-MARK)))
+            |do|
 (COND
+                        (PRINTFLG (PRINT (LISP:EVAL EXPR)
+                                         T))
+                        (T (LISP:EVAL EXPR))))
+         (|if|
 LOAD-VERBOSE-STREAM
+             |then|
 (LISP:FORMAT LOAD-VERBOSE-STREAM "; Finished loading ~A, ~D bytes read~&" 
+                               FULL (GETFILEPTR STREAM)))
+         FULL)))
+)
+
+(PUTPROPS CMLLOAD
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLLOAD COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (5526 6430 (\\CML-LOAD 5536 . 6428)))))
+STOP

CLTL2/CMLMACROS

@@ -0,0 +1,253 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 14:19:04" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;2"
 12700  
+
+      previous date%: "12-Jan-92 12:41:41" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMACROS.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLMACROSCOMS)
+
+(RPAQQ CMLMACROSCOMS

+       [(FNS CLISPEXPANSION GLOBAL-MACRO-FUNCTION LOCAL-MACRO-FUNCTION LOCAL-SYMBOL-FUNCTION 
+             \INTERLISP-NLAMBDA-MACRO LISP:MACRO-FUNCTION LISP:MACROEXPAND LISP:MACROEXPAND-1 
+             SETF-MACRO-FUNCTION)
+        (APPENDVARS (COMPILERMACROPROPS DMACRO BYTEMACRO MACRO))
+        (ADDVARS (GLOBALVARS COMPILERMACROPROPS))
+        (PROP MACRO *)
+        (FUNCTIONS LISP:MACROLET)
+        (SETFS LISP:MACRO-FUNCTION)
+        (PROP FILETYPE CMLMACROS)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
+                                                                             (NLAML)
+                                                                             (LAMA LISP:MACROEXPAND-1
+                                                                                   LISP:MACROEXPAND 
+                                                                                  LISP:MACRO-FUNCTION
+                                                                                   ])
+(DEFINEQ
+
+(CLISPEXPANSION

+  [LAMBDA (X ENV)                                            (* ; "Edited  4-Dec-86 01:19 by lmm")

+
+    (* ;; "the macro function for all CLISP words. Expand X as a clisp macro.")

+
+    (LISP:VALUES (do
 (LET ((NOSPELLFLG T)
+                               (LISPXHIST NIL)
+                               (VARS NIL)
+                               (COP (COPY X)))
+                              (DECLARE
 (LISP:SPECIAL NOSPELLFLG VARS LISPXHIST))
+                                                             (* ; 
+
                                                        "make a copy so dwim doesn't muck with it!")

+                              [COND
+                                 ((GETPROP (CAR X)
+                                         'CLISPWORD)
+                                  (DWIMIFY0? COP COP COP NIL NIL NIL 'VARSBOUND)
+                                  (COND
+                                     ((NOT (LISP:EQUAL COP X))
+                                                             (* ; "made a change")

+                                      (RETURN COP))
+                                     ((SETQ COP (GETHASH COP CLISPARRAY))
+                                      (RETURN COP]
+                              (LISP:CERROR "Try expanding again." "Can't CLISP expand expression ~S."
+                                     X)))
+           T])
+
+(GLOBAL-MACRO-FUNCTION

+  [LAMBDA (X ENV)                                            (* ; "Edited 22-Apr-87 19:07 by Pavel")

+    (LET (MD)
+         (COND
+            [(AND (TYPEP ENV 'COMPILER:ENV)
+                  (LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
+                         (COMPILER:ENV-FBOUNDP ENV X)
+                         (AND (EQ KIND :MACRO)
+                              EXPN-FN]
+            ((GET X 'MACRO-FN))
+            ((LISP:SPECIAL-FORM-P X)
+             NIL)
+            [[AND [NOT (FMEMB (ARGTYPE X)
+                              '(0 2]
+                  (FIND
 PROP IN
 COMPILERMACROPROPS
+                     SUCHTHAT
 (AND (SETQ MD (GETPROP X PROP))
+                                       (NOT (OR (LITATOM MD)
+                                                (FMEMB (CAR MD)
+                                                       '(APPLY APPLY*]
+             `(LAMBDA (FORM ENV)
+                (MACROEXPANSION FORM ',MD]
+            ((AND (NOT (GETD X))
+                  (GETPROP X 'CLISPWORD))
+             (FUNCTION CLISPEXPANSION))
+            ((FMEMB (ARGTYPE X)
+                    '(1 3))
+             (FUNCTION \INTERLISP-NLAMBDA-MACRO])
+
+(LOCAL-MACRO-FUNCTION

+  [LAMBDA (X ENV)                                            (* ; "Edited 13-Apr-87 11:16 by Pavel")

+    (AND ENV (LISP:TYPECASE ENV
+                 (ENVIRONMENT                                (* ; "Interpreter's environments")

+                    (LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
+                                          X)))
+                         (AND FN-DEFN (EQ (CAR FN-DEFN)
+                                          :MACRO)
+                              (CDR FN-DEFN))))
+                 (COMPILER:ENV                               (* ; "Compiler's environments.")

+                    (LISP:MULTIPLE-VALUE-BIND (KIND EXPN-FN)
+                           (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
+                           (AND (EQ KIND :MACRO)
+                                EXPN-FN))))])
+
+(LOCAL-SYMBOL-FUNCTION

+  [LAMBDA (X ENV)                                            (* ; "Edited 31-Jul-87 18:06 by amd")

+    (AND ENV (LISP:TYPECASE ENV
+                 (ENVIRONMENT                                (* ; "Interpreter's environments")

+                    (LET ((FN-DEFN (LISP:GETF (ENVIRONMENT-FUNCTIONS ENV)
+                                          X)))
+                         (AND FN-DEFN (EQ (CAR FN-DEFN)
+                                          :FUNCTION)
+                              (CDR FN-DEFN))))
+                 (COMPILER:ENV                               (* ; "Compiler's environments.")

+                    (LISP:MULTIPLE-VALUE-BIND (KIND FN)
+                           (COMPILER:ENV-FBOUNDP ENV X :LEXICAL-ONLY T)
+                           (AND (EQ KIND :FUNCTION)
+                                FN))))])
+
+(\INTERLISP-NLAMBDA-MACRO

+  [LAMBDA (X ENV)                                            (* lmm " 7-May-86 17:24")

+    `(LISP:FUNCALL (FUNCTION ,(CAR X))
+            ,@(SELECTQ (ARGTYPE (CAR X))
+                  (1 (MAPCAR (CDR X)
+                            (FUNCTION KWOTE)))
+                  (3 (LIST (KWOTE (CDR X))))
+                  (SHOULDNT])
+
+(LISP:MACRO-FUNCTION

+  [LISP:LAMBDA (LISP::X LISP::ENV)                           (* ; "Edited 12-Jan-92 11:45 by bane")

+         (AND (LISP:SYMBOLP LISP::X)
+              (NOT (LOCAL-SYMBOL-FUNCTION
 LISP::X LISP::ENV))
+              (OR (LOCAL-MACRO-FUNCTION
 LISP::X LISP::ENV)
+                  (GLOBAL-MACRO-FUNCTION
 LISP::X LISP::ENV])
+
+(LISP:MACROEXPAND

+  [LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV)              (* ; "Edited 13-Feb-87 23:47 by Pavel")

+
+(* ;;; "If FORM is a macro call, then the form is expanded until the result is not a macro. Returns as multiple values, the form after any expansion has been done and T if expansion was done, or NIL otherwise. Env is the lexical environment to expand in, which defaults to the null environment.")

+
+         (PROG (LISP::FLAG)
+               (LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
+                      (LISP:MACROEXPAND-1
 LISP::FORM LISP::ENV))
+               (LISP:UNLESS LISP::FLAG
+                   (RETURN (LISP:VALUES LISP::FORM NIL)))
+           LISP:LOOP
+               (LISP:MULTIPLE-VALUE-SETQ (LISP::FORM LISP::FLAG)
+                      (LISP:MACROEXPAND-1
 LISP::FORM LISP::ENV))
+               (LISP:IF LISP::FLAG
+                   (GO LISP:LOOP)
+                   (RETURN (LISP:VALUES LISP::FORM T)))])
+
+(LISP:MACROEXPAND-1

+  [LISP:LAMBDA (LISP::FORM &OPTIONAL LISP::ENV)              (* ; "Edited 13-Feb-87 23:49 by Pavel")

+
+(* ;;; "If form is a macro, expands it once. Returns two values, the expanded form and a T-or-NIL flag indicating whether the form was, in fact, a macro. Env is the lexical environment to expand in, which defaults to the null environment.")

+
+         (COND
+            [(AND (LISP:CONSP LISP::FORM)
+                  (LISP:SYMBOLP (CAR LISP::FORM)))
+             (LET ((LISP::DEF (LISP:MACRO-FUNCTION
 (CAR LISP::FORM)
+                                     LISP::ENV)))
+                  (COND
+                     (LISP::DEF (LISP:IF [NOT (EQ LISP::FORM (LISP:SETQ LISP::FORM
+                                                                    (LISP:FUNCALL *MACROEXPAND-HOOK*
+                                                                           LISP::DEF LISP::FORM 
+                                                                           LISP::ENV]
+                                    (LISP:VALUES LISP::FORM T)
+                                    (LISP:VALUES LISP::FORM NIL)))
+                     (T (LISP:VALUES LISP::FORM NIL]
+            (T (LISP:VALUES LISP::FORM NIL])
+
+(SETF-MACRO-FUNCTION

+  [LAMBDA (X BODY)                                           (* ; "Edited 13-Feb-87 13:26 by Pavel")

+
+    (* ;; "the SETF function for MACRO-FUNCTION ")

+
+    (* ;; "NOTE: If you change this, be sure to change the undoable version on CMLUNDO!")

+
+    (PROG1 (LISP:SETF (GET X 'MACRO-FN)
+                  BODY)
+        (AND (GETD X)
+             (SELECTQ (ARGTYPE X)
+                 ((1 3)                                      (* ; 
+
                                                         "Leave Interlisp nlambda definition alone")

+                      )
+                 (PUTD X NIL))))])
+)
+
+(APPENDTOVAR COMPILERMACROPROPS
 DMACRO BYTEMACRO MACRO)
+
+(ADDTOVAR GLOBALVARS
 COMPILERMACROPROPS)
+
+(PUTPROPS *
 MACRO
 ((X . Y)
+                           'X))
+
+(DEFMACRO LISP:MACROLET
 (LISP::MACRODEFS &BODY LISP::BODY &ENVIRONMENT LISP::ENV)
+   (DECLARE
 (SPECVARS *BYTECOMPILER-IS-EXPANDING*))
+
+   (* ;; "This macro for the old interpreter and compiler only.  The new interpreter has a special-form definition.  When the new compiler is expanding, we simply return a disguised version of the form.")

+
+   [IF
 (AND *BYTECOMPILER-IS-EXPANDING* *BYTECOMPILER-OPTIMIZE-MACROLET*)
+       THEN
 (LET ((LISP::NEW-ENV (COMPILER::MAKE-CHILD-ENV LISP::ENV)))
+                     (DECLARE
 (LISP:SPECIAL *BC-MACRO-ENVIRONMENT*))
+                     [FOR
 LISP::FN IN
 LISP::MACRODEFS
+                        DO
 (COMPILER::ENV-BIND-FUNCTION LISP::NEW-ENV (CAR LISP::FN)
+                                      :MACRO
+                                      (COMPILER::CRACK-DEFMACRO (CONS 'DEFMACRO LISP::FN]
+                     (LISP:SETQ *BC-MACRO-ENVIRONMENT* LISP::NEW-ENV)
+                     (CONS 'LISP:LOCALLY LISP::BODY))
+     ELSEIF
 (TYPEP LISP::ENV 'COMPILER:ENV)
+       THEN
 `(SI::%%MACROLET ,LISP::MACRODEFS ,@LISP::BODY)
+     ELSE

+     (LET (LISP::NEW-ENV LISP::FUNCTIONS)
+
+          (* ;; 
+
   "We parse and handle the declarations here, so they'll take effect in the new child environment")

+
+          (LISP:MULTIPLE-VALUE-BIND
+           (LISP::BODY LISP::SPECIALS)
+           (\REMOVE-DECLS LISP::BODY (LISP:SETQ LISP::NEW-ENV (\MAKE-CHILD-ENVIRONMENT LISP::ENV)))
+           (LISP:SETQ LISP::FUNCTIONS (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV))
+           (FOR
 LISP::FN IN
 LISP::MACRODEFS
+              DO
 (LISP:SETQ LISP::FUNCTIONS
+                            (LIST* (CAR LISP::FN)
+                                   [CONS :MACRO `(LISP:LAMBDA (SI::$$MACRO-FORM 
+                                                                     SI::$$MACRO-ENVIRONMENT)
+                                                        (LISP:BLOCK ,(CAR LISP::FN)
+                                                            ,(PARSE-DEFMACRO (CADR LISP::FN)
+                                                                    'SI::$$MACRO-FORM
+                                                                    (CDDR LISP::FN)
+                                                                    (CAR LISP::FN)
+                                                                    NIL :ENVIRONMENT 
+                                                                    'SI::$$MACRO-ENVIRONMENT))]
+                                   LISP::FUNCTIONS)))
+           (LISP:SETF (ENVIRONMENT-FUNCTIONS LISP::NEW-ENV)
+                  LISP::FUNCTIONS)
+           (WALK-FORM (CONS 'LISP:LOCALLY LISP::BODY)
+                  :ENVIRONMENT LISP::NEW-ENV])
+
+(LISP:DEFSETF LISP:MACRO-FUNCTION
 SETF-MACRO-FUNCTION)
+
+(PUTPROPS CMLMACROS
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 LISP:MACROEXPAND-1 LISP:MACROEXPAND LISP:MACRO-FUNCTION)
+)
+(PUTPROPS CMLMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1472 9378 (CLISPEXPANSION 1482 . 2890) (GLOBAL-MACRO-FUNCTION 2892 . 4085) (
+LOCAL-MACRO-FUNCTION 4087 . 4949) (LOCAL-SYMBOL-FUNCTION 4951 . 5808) (\INTERLISP-NLAMBDA-MACRO 5810
+ . 6169) (LISP:MACRO-FUNCTION 6171 . 6530) (LISP:MACROEXPAND 6532 . 7504) (LISP:MACROEXPAND-1 7506 . 
+8736) (SETF-MACRO-FUNCTION 8738 . 9376)))))
+STOP

CLTL2/CMLMISCIO

@@ -0,0 +1,163 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "18-Oct-93 14:20:56" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;2"
 6473   
+
+      |previous| |date:| "25-Oct-91 22:41:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLMISCIO.;1"
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLMISCIOCOMS)
+
+(RPAQQ CMLMISCIOCOMS

+       (
+        (* |;;| "Random leftover IO functions")

+
+        
+        (* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")

+
+        (FUNCTIONS LISP:Y-OR-N-P LISP:YES-OR-NO-P)
+        
+        (* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")

+
+        (FUNCTIONS HANDLE-PRINT-READABLY LISP::CHECK-READABLY)
+        (FUNCTIONS LISP:PRINT-UNREADABLE-OBJECT LISP:WITH-STANDARD-IO-SYNTAX)
+        
+        (* |;;| "Arrange to use the proper compiler")

+
+        (PROP FILETYPE CMLMISCIO)))
+
+
+
+(* |;;| "Random leftover IO functions")

+
+
+
+
+(* |;;| "[JDS 2/3/88: Removed FRESH-LINE from here, since it's also in CMLPRINT. AR #9601]")

+
+
+(LISP:DEFUN LISP:Y-OR-N-P
 (&OPTIONAL FORMAT-STRING &REST ARGUMENTS)
+   (COND
+      (FORMAT-STRING (LISP:FRESH-LINE)
+             (LISP:APPLY (FUNCTION LISP:FORMAT)
+                    *QUERY-IO* FORMAT-STRING ARGUMENTS)))
+   (LISP:FLET ((LISP::READ-CHAR-NOW NIL (RESETFORM (CONTROL T)
+                                                 (LISP:READ-CHAR *QUERY-IO*))))
+          (LISP:DO ((LISP::RESPONSE (LISP::READ-CHAR-NOW)
+                           (LISP::READ-CHAR-NOW)))
+                   ((OR (LISP:CHAR-EQUAL LISP::RESPONSE #\Y)
+                        (LISP:CHAR-EQUAL LISP::RESPONSE #\N))
+                    (LISP:FRESH-LINE)
+                    (LISP:CHAR-EQUAL LISP::RESPONSE #\Y))
+              (LISP:FORMAT *QUERY-IO* "~&Please type either Y or N: "))))
+
+(LISP:DEFUN LISP:YES-OR-NO-P
 (&OPTIONAL LISP::FORMAT-STRING &REST LISP::ARGUMENTS)
+   (LISP:WHEN LISP::FORMAT-STRING
+       (LISP:FRESH-LINE *QUERY-IO*)
+       (LISP:APPLY #'LISP:FORMAT *QUERY-IO* LISP::FORMAT-STRING LISP::ARGUMENTS))
+   (LISP:DO ((LISP::RESPONSE (LISP:READ-LINE *QUERY-IO*)
+                    (LISP:READ-LINE *QUERY-IO*)))
+            ((OR (STRING-EQUAL LISP::RESPONSE "YES")
+                 (STRING-EQUAL LISP::RESPONSE "NO"))
+             (STRING-EQUAL LISP::RESPONSE "YES"))
+       (LISP:FORMAT *QUERY-IO* "Please type either YES or NO: ")))
+
+
+
+(* |;;| "JRB - stuff that handles CL:*PRINT-READABLY*")

+
+
+(LISP:DEFUN HANDLE-PRINT-READABLY
 ()
+
+   (* |;;| "Strategy: when *PRINT-READABLY* is on, all CL top-level printing functions go through a function that rebinds all the printer control variables (like WRITE or WRITE-TO-STRING).  Calling HANDLE-PRINT-READABLY sets the control variables so output is printed readably; it also sets *PRINT-READABLY* to a magic value so functions like FORMAT and WRITE-STRING will know it's OK to write constant strings without munging them.")

+
+   (SETQ *PRINT-ESCAPE* T)
+   (SETQ *PRINT-LEVEL* NIL)
+   (SETQ *PRINT-LENGTH* NIL)
+   (SETQ *PRINT-GENSYM* T)
+   (SETQ *PRINT-ARRAY* T)
+   (SETQ *PRINT-CIRCLE* T)
+   (SETQ XCL:*PRINT-STRUCTURE* T)
+   (SETQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY))
+
+(LISP:DEFUN LISP::CHECK-READABLY
 (XCL::THING &OPTIONAL LISP::WHERE)
+   (LISP:WHEN LISP:*PRINT-READABLY*
+       (LET (LISP:*PRINT-READABLY*)
+            (CONDITIONS:RESTART-CASE (LISP:ERROR 'LISP::PRINT-NOT-READABLE :THING XCL::THING :WHERE 
+                                            LISP::WHERE)
+                   (XCL::PRINT-IT-ANYWAY NIL :REPORT (LISP:LAMBDA (STREAM)
+                                                              (LISP:PRINC "Print it anyway " STREAM))
+                          :FILTER
+                          (LISP:LAMBDA NIL (TYPEP XCL:*CURRENT-CONDITION* 
+                                                    'LISP::PRINT-NOT-READABLE)))))))
+
+(DEFMACRO LISP:PRINT-UNREADABLE-OBJECT
 ((LISP::OBJECT STREAM &KEY TYPE LISP:IDENTITY)
+                                            &BODY LISP::BODY)
+   (LET ((LISP::O (LISP:GENSYM))
+         (LISP::S (LISP:GENSYM))
+         (LISP::SPACE? (LISP:GENSYM)))
+        `(LET ((,LISP::O ,LISP::OBJECT)
+               (,LISP::S ,STREAM)
+               ,LISP::SPACE?)
+              (LISP::CHECK-READABLY
 ,LISP::O)
+              (WRITE-STRING* "#<" ,LISP::S)
+              ,@(LISP:WHEN TYPE
+                    `((LISP:WHEN ,TYPE
+                          (LISP:SETQ ,LISP::SPACE? T)
+                          (WRITE (LISP:TYPE-OF ,LISP::O)
+                                 ,LISP::S))))
+              ,@(LISP:WHEN LISP::BODY
+                    `((LISP:WHEN ,LISP::SPACE?
+                          (LISP:WRITE-CHAR #\Space ,LISP::S))
+                      (PROGN ,@LISP::BODY (LISP:SETQ ,LISP::SPACE? T))))
+              ,@(LISP:WHEN LISP:IDENTITY
+                    `((LISP:WHEN ,LISP:IDENTITY
+                          (LISP:WHEN ,LISP::SPACE?
+                              (LISP:WRITE-CHAR #\Space ,LISP::S))
+                          (WRITE-STRING* "@ " ,LISP::S)
+                          (\\PRINTADDR ,LISP::O ,LISP::S))))
+              (LISP:WRITE-CHAR #\> ,LISP::S)
+              NIL)))
+
+(DEFMACRO LISP:WITH-STANDARD-IO-SYNTAX
 (&BODY LISP::BODY)
+   `(LET ((*PACKAGE* (LISP:FIND-PACKAGE "COMMON-LISP-USER"))
+          (*PRINT-ARRAY* T)
+          (*PRINT-BASE* 10)
+          (*PRINT-CASE* :UPCASE)
+          (*PRINT-CIRCLE* NIL)
+          (*PRINT-ESCAPE* T)
+          (*PRINT-GENSYM* T)
+          (*PRINT-LENGTH* NIL)
+          (*PRINT-LEVEL* NIL)
+          (*PRINT-PRETTY* NIL)
+          (*PRINT-RADIX* NIL)
+          (LISP:*PRINT-READABLY* T)
+          (*READ-BASE* 10)
+          (*READ-DEFAULT-FLOAT-FORMAT* 'LISP:SINGLE-FLOAT)
+          (LISP:*READ-EVAL* T)
+          (*READ-SUPPRESS* NIL)
+          (*READTABLE* (FIND-READTABLE "LISP"))
+
+          (* |;;| "XP-specific variables")

+
+          (XP:*PRINT-LINES* NIL)
+          (XP:*PRINT-MISER-WIDTH* NIL)
+          (XP:*PRINT-PPRINT-DISPATCH* NIL)
+          (XP:*PRINT-RIGHT-MARGIN* NIL)
+
+          (* |;;| "XCL-specific variables")

+
+          (XCL:*PRINT-STRUCTURE* T))
+         ,@LISP::BODY))
+
+
+
+(* |;;| "Arrange to use the proper compiler")

+
+
+(PUTPROPS CMLMISCIO
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLMISCIO COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLMODULES

@@ -0,0 +1,26 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+
(IL:FILECREATED "22-May-91 09:10:07" IL:|{DSK}<new>sources>lispcore>sources>CMLMODULES.;2|
 2865   
+
+      IL:|previous| IL:|date:| "12-Jun-90 16:56:18" 
+IL:|{DSK}<new>sources>lispcore>sources>CMLMODULES.;1|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLMODULESCOMS)
+
+(IL:RPAQQ IL:CMLMODULESCOMS ((IL:VARIABLES *MODULES*) (IL:FUNCTIONS PROVIDE REQUIRE) (IL:PROP IL:FILETYPE IL:CMLMODULES) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:CMLMODULES)))
+
+(DEFVAR *MODULES* NIL "A list of all modules currently provided to the system.")
+
+(DEFUN PROVIDE (MODULE-NAME) "Declare that module-name is provided to the system." (DECLARE (SPECIAL *MODULES*)) (IF (SYMBOLP MODULE-NAME) (SETQ MODULE-NAME (SYMBOL-NAME MODULE-NAME))) (PUSHNEW MODULE-NAME *MODULES* :TEST (FUNCTION STRING=)) MODULE-NAME)
+
+(DEFUN REQUIRE (MODULE-NAME &OPTIONAL (PATHNAME NIL)) "Declare that module-name is needed.  If already loaded do nothing.  If not, load using the pathname, which is a single pathname or list of pathnames.  If pathname is not provided use the system default paths (*default-pathname-defaults* and directories)." (DECLARE (SPECIAL *MODULES* *DEFAULT-PATHNAME-DEFAULTS* IL:DIRECTORIES IL:*COMPILED-EXTENSIONS*)) (UNLESS (MEMBER MODULE-NAME *MODULES* :TEST (FUNCTION STRING=)) (LET (PATHNAMES) (LABELS ((TRY (PATHNAME) (OR (IL:* IL:\; "first look for a compiled file") (TRY-MANY PATHNAME IL:*COMPILED-EXTENSIONS*) (IL:* IL:\; "then for a source file") (TRY-MANY PATHNAME (LIST NIL)) (CERROR "Don't load file ~S~*." "Can't find file ~S for required module ~S." PATHNAME MODULE-NAME))) (TRY-MANY (PATHNAME TYPES) (IL:* IL:|;;| "look first on connected directory, then IL:DIRECTORIES") (DOLIST (DIRECTORY (CONS *DEFAULT-PATHNAME-DEFAULTS* IL:DIRECTORIES)) (DOLIST (TYPE TYPES) (WHEN (TRY-ONE (MERGE-PATHNAMES PATHNAME (MAKE-PATHNAME :TYPE TYPE :DEFAULTS DIRECTORY))) (RETURN-FROM TRY-MANY T))))) (TRY-ONE (PATHNAME) (IL:* IL:|;;| "don't try any pathname more than once") (UNLESS (MEMBER PATHNAME PATHNAMES :TEST (QUOTE EQUAL)) (PUSH PATHNAME PATHNAMES) (WHEN (PROBE-FILE PATHNAME) (UNLESS (FIND (IL:PACKFILENAME (QUOTE IL:DIRECTORY) (FORMAT NIL "{~a}~a" (PATHNAME-HOST PATHNAME) (PATHNAME-DIRECTORY PATHNAME)) (QUOTE IL:BODY) (PATHNAME-NAME PATHNAME) (QUOTE IL:VERSION) (PATHNAME-VERSION PATHNAME)) IL:LOADEDFILELST) (LOAD PATHNAME)) T)))) (DOLIST (PATHNAME (ETYPECASE PATHNAME (NULL (LIST MODULE-NAME)) ((OR SYMBOL STRING PATHNAME) (LIST PATHNAME)) (LIST PATHNAME)) T) (TRY PATHNAME))))))
+
+(IL:PUTPROPS IL:CMLMODULES IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLMODULES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:PUTPROPS IL:CMLMODULES IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLMVS

@@ -0,0 +1,69 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "24-Mar-92 14:05:50" {DSK}<usr>local>lde>lispcore>sources>CMLMVS.;2
 4265   
+
+      changes to%:  (VARS CMLMVSCOMS) (FUNCTIONS CL:NTH-VALUE)
+
+      previous date%: "16-May-90 13:35:04" {DSK}<usr>local>lde>lispcore>sources>CMLMVS.;1)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLMVSCOMS)
+
+(RPAQQ CMLMVSCOMS ((* ; "Interpreter and compiler support for multiple values.  See LLMVS for runtime support") (FNS CL:MULTIPLE-VALUE-CALL RETVALUES) (PROP DMACRO CL:MULTIPLE-VALUE-CALL) (FUNCTIONS CL:MULTIPLE-VALUE-BIND CL:MULTIPLE-VALUE-LIST CL:MULTIPLE-VALUE-PROG1 CL:MULTIPLE-VALUE-SETQ CL:NTH-VALUE) (VARS (NEW-ADVISETEMPLATE (QUOTE (ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES))))))) (PROP FILETYPE CMLMVS) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA CL:MULTIPLE-VALUE-CALL) (NLAML) (LAMA)))))
+
+
+
+(* ; "Interpreter and compiler support for multiple values.  See LLMVS for runtime support")

+
+(DEFINEQ
+
+(CL:MULTIPLE-VALUE-CALL

+  [NLAMBDA FORMS
+    (DECLARE
 (LOCALVARS . T))                                (* ; "Edited 16-Dec-86 15:35 by bvm:")
+          
+          (* ;; "for interpreted calls only.  Note that CL:APPLY will compile ok here, because this is in return context, so UNBIND doesn't get in the way.")
+
+    (CL:APPLY (\EVAL (CAR FORMS))
+           (for
 X in
 (CDR FORMS) join
 (CL:MULTIPLE-VALUE-LIST (\EVAL X])
+
+(RETVALUES

+  [LAMBDA (POS VALUES FLG)                                   (* bvm%: "10-Nov-86 18:13")
+    (LET ((P (\STACKARGPTR POS)))
+         (COND
+            ((fetch
 (FX INVALIDP) of
 (SETQ P (fetch
 (FX CLINK) of
 P)))
+             (LISPERROR "ILLEGAL RETURN" VALUES)))
+         (\SMASHRETURN NIL P)
+         (AND FLG (RELSTK POS))
+         (CL:VALUES-LIST VALUES])
+)
+
+(PUTPROPS CL:MULTIPLE-VALUE-CALL DMACRO (DEFMACRO (FN &BODY BODY) (* ;; "How to compile special form MULTIPLE-VALUE-CALL --- for benefit of macro writers, handle some degenerate cases and let the rest turn into an APPLY.  This is not an OPTIMIZER because pavcompiler intercepts it for its own use.") (COND ((AND (LISTP FN) (MEMB (CAR FN) (QUOTE (FUNCTION LISP:FUNCTION))) (MEMB (CADR FN) (QUOTE (LIST CL:VALUES)))) (if (NULL (CDR BODY)) then (* ; "only one source of values.  Either sole arg is the result itself, or a list of its values is") (CONS (if (EQ (CADR FN) (QUOTE LIST)) then (QUOTE \MVLIST) else (QUOTE PROGN)) BODY) else (* ; "Produce a list consisting of all args spread.  This is either the result itself, or to be spread as values") (BQUOTE ((\, (if (EQ (CADR FN) (QUOTE LIST)) then (QUOTE PROGN) else (QUOTE CL:VALUES-LIST))) (NCONC (\,@ (for F in BODY collect (BQUOTE (\MVLIST (\, F)))))))))) (T (BQUOTE (APPLY (\, FN) (NCONC (\,@ (for F in BODY collect (BQUOTE (\MVLIST (\, F))))))))))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-BIND (VARS VALUES-FORM &REST FORMS) (BQUOTE (DESTRUCTURING-BIND (\, VARS) (CL:MULTIPLE-VALUE-LIST (\, VALUES-FORM)) (\,@ FORMS))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-LIST (FORM) (BQUOTE (CL:MULTIPLE-VALUE-CALL (FUNCTION LIST) (\, FORM))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-PROG1 (FORM . OTHER-FORMS) (BQUOTE (CL:VALUES-LIST (PROG1 (CL:MULTIPLE-VALUE-LIST (\, FORM)) (\,@ OTHER-FORMS)))))
+
+(DEFMACRO CL:MULTIPLE-VALUE-SETQ (VARIABLES FORM) (LET ((LIST (GENSYM))) (BQUOTE (LET (((\, LIST) (CL:MULTIPLE-VALUE-LIST (\, FORM)))) (DESTRUCTURING-SETQ (\, VARIABLES) (\, LIST)) (CAR (\, LIST))))))
+
+(DEFMACRO CL:NTH-VALUE (CL::N CL::FORM) (BQUOTE (CL:NTH (\, CL::N) (CL:MULTIPLE-VALUE-LIST (\, CL::FORM)))))
+
+(RPAQQ NEW-ADVISETEMPLATE (ADV-PROG (!VALUE !OTHER-VALUES) (CL:MULTIPLE-VALUE-SETQ (!VALUE . !OTHER-VALUES) (ADV-PROG NIL (ADV-RETURN DEF))) (ADV-RETURN (CL:VALUES-LIST (CONS !VALUE !OTHER-VALUES)))))
+
+(PUTPROPS CMLMVS FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA CL:MULTIPLE-VALUE-CALL)
+
+(ADDTOVAR NLAML)
+
+(ADDTOVAR LAMA)
+)
+(PUTPROPS CMLMVS COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1990 1992))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1215 2052 (CL:MULTIPLE-VALUE-CALL 1225 . 1662) (RETVALUES 1664 . 2050)))))
+STOP

CLTL2/CMLPACKAGE

@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+
(il:filecreated "14-Jun-90 17:33:55" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;3|
 22253  
+
+      il:|previous| il:|date:| "16-May-90 14:12:37" il:|{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLPACKAGE.;2|
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+
+(il:prettycomprint il:cmlpackagecoms)
+
+(il:rpaqq il:cmlpackagecoms
 ((il:* il:|;;;| "This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init") (il:setfs symbol-package) (il:functions il:dwim-symbol-package escape-colons-proceed make-external-proceed make-internal-proceed ugly-symbol-proceed) (il:declare\: il:donteval@load il:docopy (il:addvars (il:dwimuserforms (il:dwim-symbol-package)))) (il:* il:|;;| "User friendly symbol error resolving functions") (il:structures read-conflict missing-external-symbol missing-package) (il:variables *preferred-reading-symbols*) (il:functions il:resolve-reader-conflict il:resolve-missing-external-symbol il:resolve-missing-package) (il:structures package-error symbol-conflict use-conflict export-conflict export-missing import-conflict unintern-conflict) (il:functions il:resolve-use-package-conflict il:resolve-export-conflict il:resolve-export-missing il:resolve-import-conflict il:resolve-unintern-conflict) (il:structures symbol-colon-error) (il:functions il:\\invalid.symbol (il:* il:\; "Also defined (w/o the error condition or proceed case) in LLREAD.")) (il:* il:|;;| "Symbol inspector") (il:functions il:symbol-inspect-fetchfn il:symbol-inspect-storefn) (il:p (let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package inspector") (il:functions il:package-inspect-fetchfn il:package-inspect-storefn) (il:p (let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package-hashtable inspector") (il:functions il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn) (il:p (let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))) (il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)") (il:functions package-prefix setf-package-prefix) (il:setfs package-prefix) (il:prop (il:filetype il:makefile-environment) il:cmlpackage) (il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars (il:addvars (il:nlama) (il:nlaml) (il:lama))))
+)
+
+
+
+(il:* il:|;;;| 
+"This is the second part of the package system, the first is in LLPACKAGE, which is loaded during the init"
+)

+
+
+(defsetf symbol-package il:setf-symbol-package)
+
+(defun il:dwim-symbol-package nil (declare (special il:faultx il:faultapplyflg)) (il:* il:|;;| "This is placed on DWIMUSERFORMS to attempt corrections where the typed symbol is in the wrong package.") (let ((il:sym (or (car (il:listp il:faultx)) il:faultx)) il:others) (cond ((and (il:litatom il:sym) (cdr (il:setq il:others (find-all-symbols (symbol-name il:sym)))) (il:setq il:others (il:|for| il:x il:|in| il:others il:|collect| il:x il:|when| (and (il:neq il:x il:sym) (not (keywordp il:x)) (il:|if| (and (il:litatom il:faultx) (not il:faultapplyflg)) il:|then| (il:* il:\; "Error is uba") (boundp il:x) il:|else| (fboundp il:x)))))) (il:|for| il:choice il:|in| il:others il:|when| (il:fixspell1 il:sym il:choice nil t (and (cdr il:others) (quote il:mustapprove))) il:|do| (il:* il:|;;| "Normally there is only one choice, and we offer it.  If there is more than one choice, probably should do something like a menu.  This is quick and dirty--ask user for each in turn and require approval so that it doesn't choose the first automatically.") (return (il:|if| (il:listp il:faultx) il:|then| (il:* il:\; "SYM = (CAR FAULTX)") (il:/rplaca il:faultx il:choice) il:|else| il:choice)))))))
+
+(define-proceed-function escape-colons-proceed :condition symbol-colon-error :report "Treat the extra colon(s) as if they were escaped")
+
+(define-proceed-function make-external-proceed :condition missing-external-symbol :report "Return a new external symbol by that name" (condition *current-condition*))
+
+(define-proceed-function make-internal-proceed :condition missing-external-symbol :report "Return a new internal symbol by that name")
+
+(define-proceed-function ugly-symbol-proceed :condition missing-package)
+(il:declare\: il:donteval@load il:docopy 
+
+(il:addtovar il:dwimuserforms
 (il:dwim-symbol-package))
+)
+
+
+
+(il:* il:|;;| "User friendly symbol error resolving functions")

+
+
+(define-condition read-conflict (read-error) (name packages) (:report (lambda (condition stream) (quote (format stream "Symbols named ~a exist in packages:~{~a ~}" (read-conflict-name condition) (mapcar (function package-name) (read-conflict-packages condition)))) (format stream "Symbols named ~A exists in packages:" (read-conflict-name condition)) (dolist (pkg (read-conflict-packages condition)) (princ " " stream) (princ (package-name pkg) stream)))))
+
+(define-condition missing-external-symbol (read-error) (name package) (:report (lambda (condition stream) (format stream "External symbol ~a not found in package ~a" (missing-external-symbol-name condition) (package-name (missing-external-symbol-package condition))))))
+
+(define-condition missing-package (read-error) (package-name symbol-name external) (:report (lambda (condition stream) (format stream "Can't find package ~a to look up symbol ~a" (missing-package-package-name condition) (missing-package-symbol-name condition)))))
+
+(defvar *preferred-reading-symbols* (quote (il:append il:apply il:apropos il:array il:arrayp il:assoc il:atan il:atom il:block il:break il:char il:character il:close il:common il:compile il:compile-file il:cos il:count il:defstruct il:delete il:describe il:directory il:do il:documentation il:elt il:equal il:error il:eval il:every il:exp il:expt il:fill-pointer il:find il:first il:floatp il:floor il:format il:function il:gcd il:gensym il:gethash il:if il:intersection il:keyword il:labels il:lambda il:ldiff il:length il:listp il:load il:locally il:log il:loop il:map il:mapc il:mapcar il:mapcon il:maphash il:maplist il:member il:merge il:mismatch il:mod il:namestring il:notany il:notevery il:nth il:number il:numberp il:numerator il:pop il:position il:prin1 il:print il:push il:pushnew il:rational il:read il:readtable il:remove il:replace il:rest il:reverse il:search il:second il:setq il:signed-byte il:simple-string il:sin il:some il:sort il:sqrt il:stringp il:structure il:sublis il:subseq il:subst il:symbol il:tan il:terpri trace il:union il:unless il:values il:variable il:vector il:when il:zerop il:* il:***)) "List of symbols whose lookup is preferred by the litatom to symbol converter.  Initially it contains a list of symbols which are conflicting but are always qualified in old sources.")
+
+(defun il:resolve-reader-conflict (il:ilsym il:clsym il:clsymwhere) "Reader finds unqualified symbol that exists in both InterLisp and Lisp.  Checks *PREFERRED-READING-SYMBOLS* list against names." (declare (special *preferred-reading-symbols*)) (il:* il:|;;| "CAUTION: Do not attempt to move the namestring check from \\NEW.READ.SYMBOL into this function as RESOLVE-READER-CONFLICT has a dummy definition in the INIT.  Also, namestring resolutions must be made during the time that packages are turned off in the beginning of the INIT.") (cond ((not (eq il:clsymwhere :external)) (il:* il:\; "Will not resolve internal (therefore private) symbols from LISP") il:ilsym) (t (let ((il:ilpreferred (member il:ilsym *preferred-reading-symbols* :test (quote eq))) (il:clpreferred (member il:clsym *preferred-reading-symbols* :test (quote eq)))) (cond ((and il:ilpreferred (not il:clpreferred)) il:ilsym) ((and il:clpreferred (not il:ilpreferred)) il:clsym) (t (il:* il:\; "Raise the signal") (restart-case (error (quote read-conflict) :name (symbol-name il:ilsym) :packages (list (find-package "LISP") (find-package "INTERLISP"))) (prefer-clsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the LISP symbol ~A; make it preferred" il:clsym)) il:clsym) (prefer-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Return the INTERLISP symbol ~A; make it preferred" il:ilsym)) (setq *preferred-reading-symbols* (remove il:clsym *preferred-reading-symbols* :test (function eq))) (push il:ilsym *preferred-reading-symbols*) il:ilsym) (return-ilsym-proceed nil :condition read-conflict :report (lambda (stream) (format stream "Just return the INTERLISP symbol ~A" il:ilsym)) il:ilsym))))))))
+
+(defun il:resolve-missing-external-symbol (il:name package) "Handle missing external symbols in a package during read." (let ((il:my-condition (make-condition (quote missing-external-symbol) :name il:name :package package))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (make-external-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new external symbol in package ~A named ~A" (package-name package) il:name)) (let ((il:symbol (intern il:name package))) (export il:symbol package) il:symbol)) (make-internal-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return a new internal symbol in package ~A named ~A" (package-name package) il:name)) (intern il:name package))))))
+
+(defun il:resolve-missing-package (package-name symbol-name externalp) (let ((il:my-condition (make-condition (quote missing-package) :package-name package-name :symbol-name symbol-name :external externalp))) (flet ((il:filter nil (eq *current-condition* il:my-condition))) (restart-case (error il:my-condition) (new-package-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new symbol named ~A made in new package ~A" symbol-name package-name)) (let* ((package (make-package (missing-package-package-name il:my-condition))) (symbol (intern (missing-package-symbol-name il:my-condition) package))) (when (missing-package-external il:my-condition) (export symbol package)) symbol)) (ugly-symbol-proceed nil :filter il:filter :report (lambda (stream) (format stream "Return new ugly symbol |~a~a~a| made in current package ~a" package-name (if externalp ":" "::") symbol-name (package-name *package*))) :interactive (lambda nil (list *package*)) (intern (il:concat (missing-package-package-name il:my-condition) (if (missing-package-external il:my-condition) ":" "::") (missing-package-symbol-name il:my-condition)) *package*))))))
+
+(define-condition package-error (error) (package))
+
+(define-condition symbol-conflict (package-error) (symbols))
+
+(define-condition use-conflict (symbol-conflict) (used-package) (:report (lambda (condition *standard-output*) (format t "Package ~a using ~a results in name conflicts for symbols:~%~{~s ~}" (package-name (use-conflict-package condition)) (package-name (use-conflict-used-package condition)) (use-conflict-symbols condition)))))
+
+(define-condition export-conflict (symbol-conflict) (exported-symbols packages) (:report (lambda (condition *standard-output*) (format t "Exporting these symbols from the ~a package:~%~{~s ~}~%results in name conflicts with package(s):~%~{~a ~}~%" (package-name (export-conflict-package condition)) (export-conflict-symbols condition) (mapcar (function package-name) (export-conflict-packages condition))))))
+
+(define-condition export-missing (package-error) (symbols) (:report (lambda (condition *standard-output*) (format t "These symbols aren't in package ~a; can't export them from it:~%~{~s ~}" (package-name (export-missing-package condition)) (export-missing-symbols condition)))))
+
+(define-condition import-conflict (symbol-conflict) nil (:report (lambda (condition *standard-output*) (format t "Importing these symbols into package ~a causes a name conflict:~%~{~s ~}" (package-name (import-conflict-package condition)) (import-conflict-symbols condition)))))
+
+(define-condition unintern-conflict (symbol-conflict) (symbol) (:report (lambda (condition *standard-output*) (format t "Uninterning symbol ~s causes a name conflict among these symbols:~%~{~s ~}" (unintern-conflict-symbol condition) (unintern-conflict-symbols condition)))))
+
+(defun il:resolve-use-package-conflict (used-package symbols package) "Handle a conflict from use-package." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote use-conflict) :package package :symbols symbols :used-package used-package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadow-use-conflicts-proceed nil :filter filter :report (lambda (stream) (format stream "Shadow conflicting symbols from ~A in ~A" (package-name used-package) (package-name package))) (dolist (symbol symbols) (shadow symbol package))) (unintern-user-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (DANGEROUS)" (package-name package))) (dolist (symbol symbols) (il:moby-unintern symbol package))) (unintern-usee-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols from ~A (VERY DANGEROUS)" (package-name used-package))) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) used-package) used-package))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort making package ~a use ~a" (package-name package) (package-name used-package))) (il:retfrom (quote use-package) nil))))))
+
+(defun il:resolve-export-conflict (package symbols packages exported-symbols) "Handle a conflict raised by export." (il:setq symbols (sort symbols (quote string<))) (setq packages (sort packages (function (lambda (a b) (string< (package-name a) (package-name b)))))) (let ((my-condition (make-condition (quote export-conflict) :package package :symbols symbols :exported-symbols exported-symbols :packages packages))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (unintern-proceed nil :filter filter :report (lambda (stream) (format stream "Unintern all conflicting symbols in package~P~{ ~a~} (DANGEROUS)" (if (null (rest packages)) 0 1) (mapcar (function package-name) packages))) (dolist (package packages exported-symbols) (dolist (symbol symbols) (il:moby-unintern (find-symbol (symbol-name symbol) package) package)))) (abort nil :filter filter :report (lambda (stream) (format stream "Abort exporting the symbols from package ~a" (package-name package))) (il:retfrom (quote export) nil))))))
+
+(defun il:resolve-export-missing (package symbols) "Handle missing symbols needed to export." (setq symbols (sort symbols (quote string<))) (let ((my-condition (quote export-missing) :package package :symbols symbols (make-condition))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (import-proceed nil :filter filter :report (lambda (stream) (format stream "Import missing symbols into ~A, then export them" package)) (import symbols package)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort export from package ~A" package)) (il:retfrom (quote export) nil))))))
+
+(defun il:resolve-import-conflict (package symbols) "Handle conflict signalled by import.  Returning from here does shadowing import." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote import-conflict) :package package :symbols symbols))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed nil :filter filter :report (lambda (stream) (format stream "Import symbols into ~S with ~S instead" (package-name package) (quote shadowing-import))) nil) (abort nil :filter filter :report (lambda (stream) (format stream "Abort import into package ~S" (package-name package))) (il:retfrom (quote import) nil))))))
+
+(defun il:resolve-unintern-conflict (symbol symbols package) "Handle a conflict noted by unintern." (setq symbols (sort symbols (quote string<))) (let ((my-condition (make-condition (quote unintern-conflict) :symbol symbol :symbols symbols :package package))) (flet ((filter nil (eq *current-condition* my-condition))) (restart-case (error my-condition) (shadowing-import-proceed (symbol-to-import) :filter filter :report (lambda (stream) (format stream "Choose symbol and ~S it to hide conflicts in package ~S" (quote shadowing-import) (package-name package))) :interactive (lambda nil (loop (let ((symbol (il:menu (il:create il:menu il:title il:_ "Choose symbol to shadowing-import" il:items il:_ symbols il:centerflg il:_ t)))) (when (member symbol symbols :test (function eq)) (return (list symbol)))))) (shadowing-import symbol-to-import package) (il:retfrom (quote il:resolve-unintern-conflict) t)) (abort nil :filter filter :report (lambda (stream) (format stream "Abort unintern of symbol ~s from package ~s" symbol (package-name package))) (il:retfrom (quote unintern) nil))))))
+
+(define-condition symbol-colon-error (read-error) (name) (:report (lambda (condition *standard-output*) (format t "Invalid symbol syntax in \"~A\"" (symbol-colon-error-name condition)))))
+
+(defun il:\\invalid.symbol (base len ncolons package extrasegments) (il:* il:|;;;| "Called when scanning a symbol that has more than 2 colons, or more than 1 non-consecutive colon.  If return from here, will read the symbol as though the extra colons were escaped.") (declare (special il:\\fatpnamestringp) (il:* il:\; "This ain't my fault, honest.")) (let ((my-condition (make-condition (quote symbol-colon-error) :name (il:concat (if (and package (not (eq package il:*keyword-package*))) (if (stringp package) package (package-name package)) "") (case ncolons (1 ":") (2 "::") (t "")) (il:\\getbasestring base 0 len il:\\fatpnamestringp))))) (restart-case (error my-condition) (escape-colons-proceed nil :filter (lambda nil (eq *current-condition* my-condition)) :report "Treat the extra colon(s) as if they were escaped" nil))))
+
+
+
+(il:* il:|;;| "Symbol inspector")

+
+
+(defun il:symbol-inspect-fetchfn (il:object il:property) (case il:property (il:name (symbol-name il:object)) (il:value (if (boundp il:object) (symbol-value il:object) (quote il:nobind))) (il:plist (symbol-plist il:object)) (package (symbol-package il:object))))
+
+(defun il:symbol-inspect-storefn (il:object il:property il:value) (case il:property (il:name (il:promptprint "Can't set symbol name")) (il:value (setf (symbol-value il:object) il:value)) (il:plist (setf (symbol-plist il:object) il:value)) (package (setf (symbol-package il:object) il:value))))
+
+(let ((il:form (quote ((il:function symbolp) (il:name il:value il:plist package) il:symbol-inspect-fetchfn il:symbol-inspect-storefn nil nil nil "Symbol inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package inspector")

+
+
+(defun il:package-inspect-fetchfn (il:object il:property) (case il:property (il:name (lisp::%package-name il:object)) (il:nicknames (lisp::%package-nicknames il:object)) (il:use-list (lisp::%package-use-list il:object)) (il:internal-symbols (lisp::%package-internal-symbols il:object)) (il:external-symbols (lisp::%package-external-symbols il:object)) (il:shadowing-symbols (lisp::%package-shadowing-symbols il:object))))
+
+(defun il:package-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package"))
+
+(let ((il:form (quote ((il:function packagep) (il:name il:nicknames il:use-list il:internal-symbols il:external-symbols il:shadowing-symbols) il:package-inspect-fetchfn il:package-inspect-storefn nil nil nil "Package inspector")))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package-hashtable inspector")

+
+
+(defun il:package-hashtable-inspect-fetchfn (il:object il:property) (case il:property (il:size (lisp::package-hashtable-size il:object)) (il:free (lisp::package-hashtable-free il:object)) (il:deleted (lisp::package-hashtable-deleted il:object)) (il:contents (lisp::package-hashtable-table il:object))))
+
+(defun il:package-hashtable-inspect-storefn (il:object il:property il:value) (il:promptprint "Can't set the fields of a package-hashtable"))
+
+(let ((il:form (quote ((il:function lisp::package-hashtable-p) (il:size il:free il:deleted il:contents) il:package-hashtable-inspect-fetchfn il:package-hashtable-inspect-storefn)))) (cond ((not (il:member il:form il:inspectmacros)) (il:|push| il:inspectmacros il:form))))
+
+
+
+(il:* il:|;;| "Package's Prefix accessor and setfs (Edited by TT 14-June-90 for AR#11112)")

+
+
+(defun package-prefix (package) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (lisp::%package-namesymbol (il:\\packagify package)))
+
+(defun setf-package-prefix (package prefix) (il:* il:\; "Edited by TT (14-June-90 : for AR#111122)") (if (symbolp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) prefix) (if (stringp prefix) (setf (lisp::%package-namesymbol (il:\\packagify package)) (intern prefix)) (error "~S must be symbol or string." prefix))))
+
+(defsetf package-prefix setf-package-prefix)
+
+(il:putprops il:cmlpackage il:filetype
 :compile-file)
+
+(il:putprops il:cmlpackage il:makefile-environment
 (:readtable "XCL" :package "XCL"))
+(il:declare\: il:donteval@load il:doeval@compile il:dontcopy il:compilervars 
+
+(il:addtovar il:nlama
 )
+
+(il:addtovar il:nlaml
 )
+
+(il:addtovar il:lama
 )
+)
+(il:putprops il:cmlpackage il:copyright ("Venue & Xerox Corporation" 1986 1987 1988 1990))
+(il:declare\: il:dontcopy
+  (il:filemap (nil)))
+il:stop

CLTL2/CMLPRINT

@@ -0,0 +1,363 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 14:35:18" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;2"
 16374  
+
+      previous date%: " 8-Jul-92 17:21:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPRINT.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLPRINTCOMS)
+
+(RPAQQ CMLPRINTCOMS

+       [(FNS WRITE LISP:WRITE-CHAR LISP:PRIN1 LISP:PRINT LISP:TERPRI LISP:FRESH-LINE 
+             LISP:FINISH-OUTPUT LISP:FORCE-OUTPUT LISP:CLEAR-OUTPUT LISP:PPRINT LISP:PRINC)
+        (FUNCTIONS \WRITE1)
+        (FNS LISP:WRITE-TO-STRING LISP:PRIN1-TO-STRING LISP:PRINC-TO-STRING)
+        (FNS WRITE-STRING*)
+        (FUNCTIONS LISP:WRITE-STRING LISP:WRITE-LINE)
+        (INITVARS (XCL:*PRINT-STRUCTURE*))
+        (VARIABLES LISP:*PRINT-READABLY*)
+        (PROP FILETYPE CMLPRINT)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 
+                            LISP:WRITE-CHAR WRITE])
+(DEFINEQ
+
+(WRITE

+  (LISP:LAMBDA (OBJECT &KEY (STREAM *STANDARD-OUTPUT*)
+                      ((:ESCAPE *PRINT-ESCAPE*)
+                       *PRINT-ESCAPE*)
+                      ((:RADIX *PRINT-RADIX*)
+                       *PRINT-RADIX*)
+                      ((:BASE *PRINT-BASE*)
+                       *PRINT-BASE*)
+                      ((:LEVEL *PRINT-LEVEL*)
+                       *PRINT-LEVEL*)
+                      ((:LENGTH *PRINT-LENGTH*)
+                       *PRINT-LENGTH*)
+                      ((:CASE *PRINT-CASE*)
+                       *PRINT-CASE*)
+                      ((:GENSYM *PRINT-GENSYM*)
+                       *PRINT-GENSYM*)
+                      ((:ARRAY *PRINT-ARRAY*)
+                       *PRINT-ARRAY*)
+                      ((:PRETTY *PRINT-PRETTY*)
+                       *PRINT-PRETTY*)
+                      ((:CIRCLE *PRINT-CIRCLE*)
+                       *PRINT-CIRCLE*)
+                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
+                       XP:*PRINT-PPRINT-DISPATCH*)
+                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
+                       XP:*PRINT-RIGHT-MARGIN*)
+                      ((:LINES XP:*PRINT-LINES*)
+                       XP:*PRINT-LINES*)
+                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
+                       XP:*PRINT-MISER-WIDTH*)
+                      ((:READABLY LISP:*PRINT-READABLY*)
+                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:23 by jrb:")

+         (DECLARE
 (LISP:SPECIAL *PRINT-ESCAPE* *PRINT-RADIX* *PRINT-BASE* *PRINT-LEVEL* 
+                             *PRINT-LENGTH* *PRINT-CASE* *PRINT-GENSYM* *PRINT-ARRAY* *PRINT-PRETTY*
+                             *PRINT-CIRCLE* XP:*PRINT-PPRINT-DISPATCH* XP:*PRINT-RIGHT-MARGIN* 
+                             XP:*PRINT-LINES* XP:*PRINT-MISER-WIDTH* LISP:*PRINT-READABLY* 
+                             *PRINT-CIRCLE-HASHTABLE* *PRINT-CIRCLE-NUMBER* THERE-ARE-CIRCLES))
+                                                             (* ; 
+
                                                "Make sure STREAM ends up as an appropriate stream")

+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
+         [COND
+            [*PRINT-PRETTY* (COND
+                               ((XP::XP-STRUCTURE-P STREAM)
+                                (XP::WRITE+ OBJECT STREAM))
+                               (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
+                                                                           (XP::WRITE+ LISP::O 
+                                                                                  LISP::S))
+                                         STREAM OBJECT]
+            ((OR (NOT *PRINT-CIRCLE*)
+                 *PRINT-CIRCLE-HASHTABLE*)
+             (\WRITE1
 OBJECT STREAM))
+            (T (LET ((*PRINT-CIRCLE-NUMBER* 1)
+                     (*PRINT-CIRCLE-HASHTABLE* (LISP:MAKE-HASH-TABLE))
+                     THERE-ARE-CIRCLES)
+                    (DECLARE
 (LISP:SPECIAL *PRINT-CIRCLE-NUMBER* *PRINT-CIRCLE-HASHTABLE* 
+                                        THERE-ARE-CIRCLES))
+                    (PRINT-CIRCLE-SCAN OBJECT)
+                    (COND
+                       ((NOT THERE-ARE-CIRCLES)
+                        (LISP:SETQ *PRINT-CIRCLE-HASHTABLE* NIL)))
+                    (\WRITE1
 OBJECT STREAM]
+         OBJECT))
+
+(LISP:WRITE-CHAR

+  (LISP:LAMBDA (CHARACTER &OPTIONAL STREAM)                  (* ; "Edited 11-Oct-91 23:44 by jrb:")

+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+         [COND
+            ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+             (XP::WRITE-CHAR+ CHARACTER STREAM))
+            [LISP:*PRINT-READABLY* (LET ((*PRINT-ESCAPE* T))
+                                        (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
+            (T (\OUTCHAR STREAM (LISP:CHAR-INT CHARACTER]
+         CHARACTER))
+
+(LISP:PRIN1

+  (LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)              (* ; "Edited 20-Feb-87 16:58 by bvm:")

+         (WRITE
 OBJECT :STREAM OUTPUT-STREAM :ESCAPE T)))
+
+(LISP:PRINT

+  (LISP:LAMBDA (OBJECT &OPTIONAL (STREAM *STANDARD-OUTPUT*)) (* ; "Edited 20-Oct-91 21:16 by jrb:")

+         (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+
+         (* ;; "The *PRINT-READABLY* case is forced through PRIN1 which goes through WRITE which rebinds everything as necessary")

+
+         (COND
+            [(AND *PRINT-PRETTY* (NOT LISP:*PRINT-READABLY*))
+             (COND
+                ((XP::XP-STRUCTURE-P STREAM)
+                 (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)
+                 (LET ((*PRINT-ESCAPE* T))
+                      (XP::BASIC-WRITE OBJECT STREAM)
+                      (XP::WRITE-CHAR++ #\Space STREAM)))
+                (T (XP::MAYBE-INITIATE-XP-PRINTING #'(LISP:LAMBDA (LISP::S LISP::O)
+                                                            (XP::WRITE+ LISP::O LISP::S))
+                          STREAM OBJECT]
+            (T (TERPRI STREAM)
+               (LISP:PRIN1
 OBJECT STREAM)
+               (SPACES 1 STREAM)))
+         OBJECT))
+
+(LISP:TERPRI

+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:56 by jrb:")

+
+    (* ;; "The clause *PRINT-PRETTY* is not necessary here: if a TERPRI is the first printing operation in a pretty-print sequence, it will be ignored anyway.")

+
+    (COND
+       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM))
+       (T (TERPRI (OR STREAM *STANDARD-OUTPUT*])
+
+(LISP:FRESH-LINE

+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:57 by jrb:")

+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (COND
+       ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::ATTEMPT-TO-OUTPUT STREAM T T)                   (* ; "ok because we want newline")

+        (LISP:WHEN (NOT (LISP:ZEROP (XP::LP<-BP STREAM)))
+            (XP::PPRINT-NEWLINE+ :FRESH STREAM)
+            T))
+       (T (FRESHLINE STREAM])
+
+(LISP:FINISH-OUTPUT

+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")

+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
+           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
+    (FORCEOUTPUT STREAM T)
+    NIL])
+
+(LISP:FORCE-OUTPUT

+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 14:01 by jrb:")

+    (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+    (LISP:IF (XP::XP-STRUCTURE-P STREAM)
+           (XP::ATTEMPT-TO-OUTPUT STREAM T T))
+    (FORCEOUTPUT STREAM)
+    NIL])
+
+(LISP:CLEAR-OUTPUT

+  [LAMBDA (STREAM)                                           (* ; "Edited 20-Sep-91 13:14 by jrb:")

+    (LISP:IF [XP::XP-STRUCTURE-P (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT]
+        (LET ((XP::*LOCATING-CIRCULARITIES* 0))              (* ; "hack to prevent visible output")

+             (XP::ATTEMPT-TO-OUTPUT STREAM T T)))
+    NIL])
+
+(LISP:PPRINT

+  (LISP:LAMBDA (OBJECT &OPTIONAL (OUTPUT-STREAM *STANDARD-OUTPUT*))
+                                                             (* lmm " 4-May-86 03:19")

+         (TERPRI OUTPUT-STREAM)
+         (WRITE
 OBJECT :STREAM OUTPUT-STREAM :ESCAPE T :PRETTY T)
+         (LISP:VALUES)))
+
+(LISP:PRINC

+  (LISP:LAMBDA (OBJECT &OPTIONAL OUTPUT-STREAM)              (* ; "Edited 20-Feb-87 16:59 by bvm:")

+         (WRITE
 OBJECT :STREAM OUTPUT-STREAM :ESCAPE NIL)))
+)
+
+(LISP:DEFUN \WRITE1
 (OBJECT STREAM)
+
+   (* ;; "This used to be where we decided if we were pretty-printing or not; the conditionality was a little strange:")

+
+   (* ;; "(CL:IF (AND *PRINT-PRETTY* (OR (NOT *PRINT-CIRCLE*) (NOT *PRINT-CIRCLE-HASHTABLE*)) *PRINT-ESCAPE*) (pretty-print-using-IL:PRINTDEF) (just-print))")

+
+   (* ;; "I don't remember why *PRINT-ESCAPE* was tested; I suspect PRINTDEF forces it on.  Anyway, we're not using PRINTDEF any more here, I hope.")

+
+   (* ;; "otherwise just print it all on one line")

+
+   (LET (\THISFILELINELENGTH)
+        (DECLARE
 (LISP:SPECIAL \THISFILELINELENGTH))
+
+        (* ;; "CommonLisp streams do not observe line length")

+
+        (\PRINDATUM OBJECT (\GETSTREAM STREAM 'OUTPUT)
+               0)))
+(DEFINEQ
+
+(LISP:WRITE-TO-STRING

+  (LISP:LAMBDA (OBJECT &KEY ((:ESCAPE *PRINT-ESCAPE*)
+                             *PRINT-ESCAPE*)
+                      ((:RADIX *PRINT-RADIX*)
+                       *PRINT-RADIX*)
+                      ((:BASE *PRINT-BASE*)
+                       *PRINT-BASE*)
+                      ((:CIRCLE *PRINT-CIRCLE*)
+                       *PRINT-CIRCLE*)
+                      ((:PRETTY *PRINT-PRETTY*)
+                       *PRINT-PRETTY*)
+                      ((:LEVEL *PRINT-LEVEL*)
+                       *PRINT-LEVEL*)
+                      ((:LENGTH *PRINT-LENGTH*)
+                       *PRINT-LENGTH*)
+                      ((:CASE *PRINT-CASE*)
+                       *PRINT-CASE*)
+                      ((:ARRAY *PRINT-ARRAY*)
+                       *PRINT-ARRAY*)
+                      ((:GENSYM *PRINT-GENSYM*)
+                       *PRINT-GENSYM*)
+                      ((:PPRINT-DISPATCH XP:*PRINT-PPRINT-DISPATCH*)
+                       XP:*PRINT-PPRINT-DISPATCH*)
+                      ((:RIGHT-MARGIN XP:*PRINT-RIGHT-MARGIN*)
+                       XP:*PRINT-RIGHT-MARGIN*)
+                      ((:LINES XP:*PRINT-LINES*)
+                       XP:*PRINT-LINES*)
+                      ((:MISER-WIDTH XP:*PRINT-MISER-WIDTH*)
+                       XP:*PRINT-MISER-WIDTH*)
+                      ((:READABLY LISP:*PRINT-READABLY*)
+                       LISP:*PRINT-READABLY*))               (* ; "Edited 11-Oct-91 23:58 by jrb:")

+         "Returns the printed representation of OBJECT as a string."
+         (LISP:WHEN LISP:*PRINT-READABLY* (HANDLE-PRINT-READABLY))
+         (LISP:IF *PRINT-PRETTY*
+             (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                    (WRITE
 OBJECT :STREAM LISP::S))
+             (\PRINDATUM.TO.STRING OBJECT))))
+
+(LISP:PRIN1-TO-STRING

+  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:25 by jrb:")

+
+(* ;;; "Produces a string consisting of the output of (PRIN1 OBJECT)")

+
+    (LET ((*PRINT-ESCAPE* T))
+
+         (* ;; 
+
"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")

+
+         (COND
+            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING
 OBJECT))
+            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                                   (WRITE
 OBJECT :STREAM LISP::S)))
+            (T (\PRINDATUM.TO.STRING OBJECT])
+
+(LISP:PRINC-TO-STRING

+  [LAMBDA (OBJECT)                                           (* ; "Edited 20-Oct-91 21:24 by jrb:")

+
+(* ;;; 
+
"A lot like MKSTRING, but not quite.  Produces a string consisting of the output of (PRINC OBJECT)")

+
+    (LET ((*PRINT-ESCAPE* NIL))
+
+         (* ;; 
+
"We force the *PRINT-READABLY* case through WRITE-TO-STRING to let it rebind the control variables ")

+
+         (COND
+            (LISP:*PRINT-READABLY* (LISP:WRITE-TO-STRING
 OBJECT))
+            (*PRINT-PRETTY* (LISP:WITH-OUTPUT-TO-STRING (LISP::S)
+                                   (WRITE
 OBJECT :STREAM LISP::S)))
+            (T (\PRINDATUM.TO.STRING OBJECT])
+)
+(DEFINEQ
+
+(WRITE-STRING*

+  [LAMBDA (STRING STREAM START END)                          (* ; "Edited 21-Oct-91 13:20 by jrb:")

+    (OR STREAM (SETQ STREAM *STANDARD-OUTPUT*))
+    (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
+        (LISP::CHECK-READABLY STRING 'WRITE-STRING*))
+    (LISP:IF (AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+        (XP::WRITE-STRING+ STRING STREAM START END)
+        [LET ((STRING-LENGTH (LISP:LENGTH STRING)))
+             (OR START (SETQ START 0))
+             (LISP:CHECK-TYPE STRING STRING)
+             (LISP:WHEN (NULL END)
+                    (SETQ END STRING-LENGTH))
+             (LISP:ASSERT (AND (<= 0 START STRING-LENGTH)
+                               (<= START END STRING-LENGTH))
+                    '(START END)
+                    "Start (~D) or end (~D) argument out of bounds." START END)
+
+             (* ;; "The following comes mainly from \PRINSTRING...")

+
+             (LET ((CHARS-TO-PRINT (- END START))
+                   \THISFILELINELENGTH)
+                  (DECLARE
 (SPECVARS \THISFILELINELENGTH))
+                  (LISP:WHEN (LISP:PLUSP CHARS-TO-PRINT)
+                      (.SPACECHECK. STREAM CHARS-TO-PRINT)
+
+                      (* ;; "Essentially (for x instring string do (\outchar strm x)).")

+
+                      (LISP:DO [(FATP (ffetch
 (STRINGP FATSTRINGP) of
 STRING))
+                                (BASE (ffetch
 (STRINGP BASE) of
 STRING))
+                                (OFFSET (IPLUS START (ffetch
 (STRINGP OFFST) of
 STRING))
+                                       (ADD1 OFFSET))
+                                (END (IPLUS END (ffetch
 (STRINGP OFFST) of
 STRING]
+                               ((>= OFFSET END))
+                          (\OUTCHAR STREAM (LISP:IF FATP
+                                               (\GETBASEFAT BASE OFFSET)
+                                               (\GETBASETHIN BASE OFFSET)))))])
+    STRING])
+)
+
+(LISP:DEFUN LISP:WRITE-STRING
 (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
+                                         &KEY
+                                         (START 0)
+                                         (END (LISP:LENGTH STRING)))
+                                                             (* ; "Edited  6-May-92 13:23 by jrb:")

+   (WRITE-STRING*
 STRING (\GETSTREAM STREAM 'OUTPUT)
+          START END)
+   STRING)
+
+(LISP:DEFUN LISP:WRITE-LINE
 (STRING &OPTIONAL (STREAM *STANDARD-OUTPUT*)
+                                       &KEY
+                                       (LISP::START 0)
+                                       LISP::END)
+   (SETQ STREAM (\GETSTREAM STREAM 'OUTPUT))
+   (LISP:UNLESS (EQ LISP:*PRINT-READABLY* 'XCL::PRINTING-READABLY)
+       (LISP::CHECK-READABLY STRING 'LISP:WRITE-LINE))
+   (COND
+      ((AND *PRINT-PRETTY* (XP::XP-STRUCTURE-P STREAM))
+       (PROGN (XP::WRITE-STRING+ STRING STREAM LISP::START LISP::END)
+              (XP::PPRINT-NEWLINE+ :UNCONDITIONAL STREAM)))
+      (T (WRITE-STRING*
 STRING STREAM LISP::START LISP::END)
+         (LISP:TERPRI
 STREAM)))
+   STRING)
+
+(RPAQ? XCL:*PRINT-STRUCTURE*
 )
+
+(LISP:DEFVAR LISP:*PRINT-READABLY*
 NIL)
+
+(PUTPROPS CMLPRINT
 FILETYPE
 :FAKE-COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 LISP:WRITE-TO-STRING LISP:PRINC LISP:PPRINT LISP:PRINT LISP:PRIN1 LISP:WRITE-CHAR
+                         WRITE)
+)
+(PUTPROPS CMLPRINT COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1991 1992 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (1214 8835 (WRITE 1224 . 4704) (LISP:WRITE-CHAR 4706 . 5230) (LISP:PRIN1 5232 . 5413) 
+(LISP:PRINT 5415 . 6424) (LISP:TERPRI 6426 . 6882) (LISP:FRESH-LINE 6884 . 7373) (LISP:FINISH-OUTPUT 
+7375 . 7675) (LISP:FORCE-OUTPUT 7677 . 7974) (LISP:CLEAR-OUTPUT 7976 . 8342) (LISP:PPRINT 8344 . 8646)
+ (LISP:PRINC 8648 . 8833)) (9611 12737 (LISP:WRITE-TO-STRING 9621 . 11419) (LISP:PRIN1-TO-STRING 11421
+ . 12054) (LISP:PRINC-TO-STRING 12056 . 12735)) (12738 14726 (WRITE-STRING* 12748 . 14724)))))
+STOP

CLTL2/CMLPROGV

@@ -0,0 +1,104 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 14:37:11" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPROGV.;2"
 5917   
+
+      previous date%: " 3-Sep-91 17:48:59" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLPROGV.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLPROGVCOMS)
+
+(RPAQQ CMLPROGVCOMS
 ((FNS \DO.PROGV \DO.PROGV.SETUP.FRAME.AND.EXECUTE)
+                         (SPECIAL-FORMS LISP:PROGV)
+                         (PROP DMACRO LISP:PROGV)
+                         (PROP FILETYPE CMLPROGV)))
+(DEFINEQ
+
+(\DO.PROGV

+  [LAMBDA (VARS VALUES FNTOCALL)                             (* ; "Edited 21-Jan-91 17:10 by jds")

+
+    (* ;; "call FNTOCALL after binding VARS to VALUES")

+
+    (DECLARE
 (LOCALVARS . T))
+    (LET ((NVARS 0)
+          NTSIZE NNILS TMP)
+         (for
 VAR in
 VARS do
 
+
+                                        (* ;; "Count number of vars to bind, check their validity")

+
+                                        (CHECK-BINDABLE VAR)
+                                        (add
 NVARS 1))
+         (.CALLAFTERPUSHINGNILS. (SETQ NNILS (IPLUS NVARS (SETQ NTSIZE
+                                                           (CEIL [ADD1 (UNFOLD NVARS (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                                ]
+                                                                 WORDSPERQUAD))
+                                                    (FOLDHI (fetch
 (FNHEADER OVERHEADWORDS)
+                                                               of
 T)
+                                                           WORDSPERCELL)
+                                                    (SUB1 CELLSPERQUAD)))
+                (\DO.PROGV.SETUP.FRAME.AND.EXECUTE
 NNILS NVARS NTSIZE VARS VALUES))
+         (LISP:FUNCALL FNTOCALL])
+
+(\DO.PROGV.SETUP.FRAME.AND.EXECUTE

+  [LAMBDA (NNILS NVARS NTSIZE VARS VALUES)                   (* ; "Edited 30-Jan-91 19:02 by jds")

+    (DECLARE
 (LOCALVARS . T))
+    (PROG ((CALLER (\MYALINK))
+           NILSTART NT HEADER)
+
+(* ;;; "Create a nametable inside CALLER where \DO.PROGV pushed all those NILs")

+
+          (SETQ HEADER (fetch
 (FX FNHEADER) of
 CALLER))
+                                                             (* ; 
+
                                                        "The function header of code for \DO.PROGV")

+          (SETQ NT (ADDSTACKBASE (CEIL (IPLUS (SETQ NILSTART (IDIFFERENCE (fetch
 (FX NEXTBLOCK)
+                                                                             of
 CALLER)
+                                                                    (UNFOLD NNILS WORDSPERCELL)))
+                                              (UNFOLD NVARS WORDSPERCELL))
+                                       WORDSPERQUAD)))
+
+     (* ;; "Address of our synthesized nametable: beginning of NIL's, not counting additional PVARs we are about to bind, rounded up to quadword")

+
+          (for
 VAR in
 VARS as
 VAR# from
 (FOLDLO (IDIFFERENCE NILSTART
+                                                                       (fetch
 (FX FIRSTPVAR)
+                                                                          of
 CALLER))
+                                                               WORDSPERCELL) as
 NT1
+             from
 (fetch
 (FNHEADER OVERHEADWORDS) of
 T) by
 (CONSTANT (
+                                                                                    WORDSPERNAMEENTRY
+                                                                                      )) as

+                                                                                         NT2
+             from
 (IPLUS (fetch
 (FNHEADER OVERHEADWORDS) of
 T)
+                             NTSIZE) by
 (CONSTANT (WORDSPERNTOFFSETENTRY)) as
 VALUEOFF
+             from
 NILSTART by
 WORDSPERCELL do
 [PUTBASEPTR \STACKSPACE VALUEOFF
+                                                                 (COND
+                                                                    (VALUES (pop
 VALUES))
+                                                                    (T 'NOBIND]
+                                                         (SETSTKNAME-RAW NT NT1 (\ATOMVALINDEX VAR))
+                                                         (SETSTKNTOFFSET-RAW NT NT2 PVARCODE VAR#))
+
+(* ;;; "now fix up header of NT")

+
+          (replace
 (FNHEADER FRAMENAME) of
 NT with
 '\PROGV)
+          (replace
 (FNHEADER NTSIZE) of
 NT with
 NTSIZE)
+          (replace
 (FX NAMETABLE) of
 CALLER with
 NT])
+)
+
+(DEFINE-SPECIAL-FORM LISP:PROGV
 (LISP::VARIABLES LISP:VALUES &REST LISP::$$PROGV-FORMS 
+                                           &ENVIRONMENT LISP::$$PROGV-ENVIRONMENT)
+
+   (* ;; "$$PROGV-FORMS and $$PROGV-ENVIRONMENT are named this wierd way because the interpreter is still compiled with the ByteCompiler and those variables will eventually be made special by that compiler.  They can get normal names whenever the new compiler starts being used on this file.")

+
+   [\DO.PROGV
 (LISP:EVAL LISP::VARIABLES LISP::$$PROGV-ENVIRONMENT)
+          (LISP:EVAL LISP:VALUES LISP::$$PROGV-ENVIRONMENT)
+          #'(LISP:LAMBDA NIL (\EVAL-PROGN LISP::$$PROGV-FORMS LISP::$$PROGV-ENVIRONMENT])
+
+(PUTPROPS LISP:PROGV
 DMACRO
 [(VARIABLES VALUES . FORMS)
+                                     (\DO.PROGV VARIABLES VALUES #'(LAMBDA NIL . FORMS])
+
+(PUTPROPS CMLPROGV
 FILETYPE
 LISP:COMPILE-FILE)
+(PUTPROPS CMLPROGV COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (639 4897 (\DO.PROGV 649 . 2064) (\DO.PROGV.SETUP.FRAME.AND.EXECUTE 2066 . 4895)))))
+STOP

CLTL2/CMLREAD

@@ -0,0 +1,334 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED " 8-Jun-90 14:17:52" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLREAD.;3|
 15466  
+
+      changes to%:  (FNS CL:READ-FROM-STRING)
+
+      previous date%: "16-May-90 14:23:07" |{PELE:MV:ENVOS}<LISPCORE>SOURCES>CMLREAD.;2|)
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLREADCOMS)
+
+(RPAQQ CMLREADCOMS
 [(COMS 
+                              (* ;; "Misc Common Lisp reader functions")

+
+                              (FNS CL:COPY-READTABLE)
+                              (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN 
+                                   CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING 
+                                   CL:READ-BYTE CL:WRITE-BYTE)
+                                                             (* ; 
+
                                                      "must turn off packed version of CLISP infix")

+                              (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *]
+                                    (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
+                                    (DWIMINMACROSFLG))
+                              (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
+                              (GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
+                        [COMS 
+                              (* ;; "Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")

+
+                              (RECORDS READER-ENVIRONMENT)
+                              (FUNCTIONS WITH-READER-ENVIRONMENT)
+                              (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
+                              (PROP INFO WITH-READER-ENVIRONMENT)
+                              (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+                              (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT 
+                                                                               REPACKAGE _
+                                                                               (CL:FIND-PACKAGE
+                                                                                "USER")
+                                                                               REREADTABLE _ CMLRDTBL
+                                                                               REBASE _ 10]
+                        (PROP FILETYPE CMLREAD)
+                        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+                               (ADDVARS (NLAMA)
+                                      (NLAML)
+                                      (LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT 
+                                            CL:READ-CHAR-NO-HANG CL:PEEK-CHAR CL:UNREAD-CHAR 
+                                            CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE])
+
+
+
+(* ;; "Misc Common Lisp reader functions")

+
+(DEFINEQ
+
+(CL:COPY-READTABLE

+  [CL:LAMBDA (&OPTIONAL (FROM-READTABLE *READTABLE*)
+                    TO-READTABLE)
                            (* bvm%: "13-Oct-86 15:21")

+                                                             (* ; 
+
                 "If FROM-READTABLE is NIL, then a copy of a standard Common Lisp readtable is made.")

+         (if
 (AND (NULL FROM-READTABLE)
+                  (NULL TO-READTABLE))
+             then
                                            (* ; "just make a brand new one")

+                  (CMLRDTBL)
+           else
 (SETQ FROM-READTABLE (\DTEST (OR FROM-READTABLE (CMLRDTBL))
+                                            'READTABLEP))
+                (if
 TO-READTABLE
+                    then
 (RESETREADTABLE (\DTEST TO-READTABLE 'READTABLEP)
+                                FROM-READTABLE)
+                         TO-READTABLE
+                  else
 (COPYREADTABLE FROM-READTABLE])
+)
+(DEFINEQ
+
+(CL:READ-LINE

+  [CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)
                   (* ; "Edited 31-Mar-87 18:36 by bvm:")

+          
+          (* ;; 
+
         "Returns a line of text read from the STREAM as a string, discarding the newline character.")

+
+         (CL:SETQ STREAM (\GETSTREAM STREAM 'INPUT))
+         (if
 (AND (NULL EOF-ERRORP)
+                  (NULL RECURSIVE-P)
+                  (\EOFP STREAM))
+             then
 EOF-VALUE
+           else
 (LET ((RESULT (RSTRING STREAM READ-LINE-RDTBL)))
+                     (if
 (\EOFP STREAM)
+                         then
 (CL:VALUES RESULT T)
+                       else
                                  (* ; "consume the eol")

+                            (READCCODE STREAM)
+                            (CL:VALUES RESULT NIL])
+
+(CL:READ-CHAR

+  [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*)
+                    (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)
                   (* ; "Edited 14-Dec-86 20:41 by bvm:")

+          
+          (* ;; "Inputs a character from STREAM and returns it.")

+
+         (LET [(STREAM (\GETSTREAM STREAM 'INPUT]
+              (COND
+                 ((AND (NOT EOF-ERRORP)
+                       (NOT RECURSIVE-P)
+                       (\EOFP STREAM))
+                  EOF-VALUE)
+                 (T (CL:CODE-CHAR (READCCODE STREAM])
+
+(CL:UNREAD-CHAR

+  (CL:LAMBDA (CHARACTER &OPTIONAL (INPUT-STREAM *STANDARD-INPUT*))

+                                                             (* bvm%: "13-Oct-86 15:44")

+          
+          (* ;; "Puts the CHARACTER back on the front of the input STREAM.  According to the manual, `One may apply UNREAD-CHAR only to the character most recently read from INPUT-STREAM.'")

+
+         (\BACKCHAR (\GETSTREAM INPUT-STREAM 'INPUT))
+         NIL))
+
+(CL:PEEK-CHAR

+  [CL:LAMBDA (&OPTIONAL (PEEK-TYPE NIL)
+                    (STREAM *STANDARD-INPUT*)
+                    (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)
                   (* ; "Edited 14-Apr-87 14:39 by bvm:")

+          
+          (* ;; "Peeks at the next character in the input Stream.  See manual for details.")

+
+         (DECLARE
 (IGNORE RECURSIVE-P))
+         (LET ((STREAM (\GETSTREAM STREAM 'INPUT))
+               (\RefillBufferFn '\PEEKREFILL)
+               CL:CHAR)
+              (DECLARE
 (CL:SPECIAL \RefillBufferFn))
+              (SELECTQ PEEK-TYPE
+                  (NIL                                       (* ; "standard case--return next char.  \peekccode to terminal requires the binding of \RefillBufferFn above")

+                       (if
 (SETQ CL:CHAR (\PEEKCCODE STREAM (NULL EOF-ERRORP)))
+                           then
 (CL:CODE-CHAR CL:CHAR)
+                         else
 EOF-VALUE))
+                  (T                                         (* ; "skip whitespace before peeking")

+                     (if
 (SETQ CL:CHAR (SKIPSEPRCODES STREAM))
+                         then
 (CL:CODE-CHAR CL:CHAR)
+                       elseif
 EOF-ERRORP
+                         then
 (\EOF.ACTION STREAM)
+                       else
 EOF-VALUE))
+                  (if
 (CL:CHARACTERP PEEK-TYPE)
+                      then
 (LET ((DESIREDCHAR (CL:CHAR-CODE PEEK-TYPE))
+                                 (NOERROR (NULL EOF-ERRORP)))
+                                (until
 (EQ (SETQ CL:CHAR (\PEEKCCODE STREAM NOERROR))
+                                           DESIREDCHAR) do
 (if
 (NULL CL:CHAR)
+                                                               then
 (RETURN EOF-VALUE))
+                                                           (READCCODE STREAM)
+                                   finally
 (RETURN PEEK-TYPE)))
+                    else
 (\ILLEGAL.ARG PEEK-TYPE])
+
+(CL:LISTEN

+  (CL:LAMBDA (&OPTIONAL STREAM)
                              (* ; "Edited 14-Apr-87 16:49 by bvm:")

+          
+          (* ;; "Returns T if a character is available on the given STREAM ")

+
+         (READP (\GETSTREAM STREAM 'INPUT)
+                T)))
+
+(CL:READ-CHAR-NO-HANG

+  (CL:LAMBDA (&OPTIONAL STREAM (EOF-ERRORP T)
+                    EOF-VALUE RECURSIVE-P)
                   (* ; "Edited 14-Apr-87 16:40 by bvm:")

+          
+          (* ;; "Returns the next character from the STREAM if one is available, or NIL.  However, if STREAM is at eof, do eof handling.")

+
+         (COND
+            ((READP STREAM T)                                (* ; "there is input, get it")

+             (CL:READ-CHAR
 STREAM EOF-ERRORP EOF-VALUE RECURSIVE-P))
+            ((NOT (EOFP STREAM))                             (* ; 
+
                                               "there could be more input, so don't wait, return NIL")

+             NIL)
+            (EOF-ERRORP (\EOF.ACTION STREAM))
+            (T EOF-VALUE))))
+
+(CL:CLEAR-INPUT

+  [CL:LAMBDA (&OPTIONAL (STREAM *STANDARD-INPUT*))
           (* bvm%: "13-Oct-86 15:46")

+          
+          (* ;; "Clears any buffered input associated with the Stream.")

+
+         (CLEARBUF (\GETSTREAM STREAM 'INPUT])
+
+(CL:READ-FROM-STRING

+  [CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE)

+                                                           (* ; "Edited  8-Jun-90 14:15 by ymasuda")

+         (LET [(STREAM (OPENSTRINGSTREAM (COND
+                                            [END (SUBSTRING STRING 1 (IMIN END (NCHARS STRING]
+                                            (T (MKSTRING STRING]
+              (COND
+                 (START (SETFILEPTR STREAM START)))
+              (CL:VALUES (CL:IF PRESERVE-WHITESPACE
+                             (CL:READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P EOF-VALUE)
+                             (CL:READ STREAM EOF-ERROR-P EOF-VALUE))
+                     (\GETFILEPTR STREAM])
+
+(CL:READ-BYTE

+  [CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
+                    EOF-VALUE)
                               (* bvm%: "13-Oct-86 15:49")

+          
+          (* ;; "Returns the next byte of the BINARY-INPUT-STREAM")

+
+         (LET [(STREAM (\GETSTREAM BINARY-INPUT-STREAM 'INPUT]
+              (CL:IF (AND (NOT EOF-ERRORP)
+                          (\EOFP STREAM))
+                     EOF-VALUE
+                     (\BIN STREAM])
+
+(CL:WRITE-BYTE

+  (CL:LAMBDA (INTEGER BINARY-OUTPUT-STREAM)
                  (* bvm%: "13-Oct-86 15:49")

+          
+          (* ;; "Outputs the INTEGER to the binary BINARY-OUTPUT-STREAM")

+
+         (BOUT BINARY-OUTPUT-STREAM INTEGER)
+         INTEGER))
+)
+
+
+
+(* ; "must turn off packed version of CLISP infix")

+
+
+(RPAQ CLISPCHARS
 (LDIFFERENCE CLISPCHARS '(- *)))
+
+(RPAQ CLISPCHARRAY
 (MAKEBITTABLE CLISPCHARS))
+
+(RPAQQ DWIMINMACROSFLG
 NIL)
+
+(CL:DEFVAR *READ-DEFAULT-FLOAT-FORMAT*
 'CL:SINGLE-FLOAT)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS CMLRDTBL READ-LINE-RDTBL)
+)
+
+
+
+(* ;; 
+"Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup"
+)

+
+(DECLARE%: EVAL@COMPILE
+
+(DATATYPE READER-ENVIRONMENT
 (REPACKAGE REREADTABLE REBASE RESPEC))
+)
+
+(/DECLAREDATATYPE 'READER-ENVIRONMENT '(POINTER POINTER POINTER POINTER)
+       '((READER-ENVIRONMENT 0 POINTER)
+         (READER-ENVIRONMENT 2 POINTER)
+         (READER-ENVIRONMENT 4 POINTER)
+         (READER-ENVIRONMENT 6 POINTER))
+       '8)
+
+(DEFMACRO WITH-READER-ENVIRONMENT
 (ENV . BODY)
+   `((CL:LAMBDA (E)
+            (LET ((*PACKAGE* (ffetch
 (READER-ENVIRONMENT REPACKAGE) of
 E))
+                  (*READTABLE* (ffetch
 (READER-ENVIRONMENT REREADTABLE) of
 E))
+                  (*READ-BASE* (ffetch
 (READER-ENVIRONMENT REBASE) of
 E))
+                  (*PRINT-BASE* (ffetch
 (READER-ENVIRONMENT REBASE) of
 E)))
+                 ,@BODY))
+     (\DTEST ,ENV 'READER-ENVIRONMENT)))
+
+(ADDTOVAR SYSSPECVARS
 *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*)
+
+(PUTPROPS WITH-READER-ENVIRONMENT INFO
 EVAL)
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+)
+
+(RPAQ? *COMMON-LISP-READ-ENVIRONMENT*
 (create READER-ENVIRONMENT REPACKAGE _ (CL:FIND-PACKAGE
+                                                                                  "USER")
+                                                 REREADTABLE _ CMLRDTBL REBASE _ 10))
+
+(PUTPROPS CMLREAD FILETYPE
 CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR
+                         CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
+)
+(PRETTYCOMPRINT CMLREADCOMS)
+
+(RPAQQ CMLREADCOMS
 
+       [(COMS 
+              (* ;; "Misc Common Lisp reader functions")

+
+              (FNS CL:COPY-READTABLE)
+              (FNS CL:READ-LINE CL:READ-CHAR CL:UNREAD-CHAR CL:PEEK-CHAR CL:LISTEN 
+                   CL:READ-CHAR-NO-HANG CL:CLEAR-INPUT CL:READ-FROM-STRING CL:READ-BYTE CL:WRITE-BYTE
+                   )
+                                                             (* ; 
+
                                                      "must turn off packed version of CLISP infix")

+              (VARS [CLISPCHARS (LDIFFERENCE CLISPCHARS '(- *]
+                    (CLISPCHARRAY (MAKEBITTABLE CLISPCHARS))
+                    (DWIMINMACROSFLG))
+              (VARIABLES *READ-DEFAULT-FLOAT-FORMAT*)
+              (GLOBALVARS CMLRDTBL READ-LINE-RDTBL))
+        [COMS 
+              (* ;; "Crude means to aid reading and printing things in same reader environment.  There are some fns and an INITRECORDS for this on ATBL to get it early in the loadup")

+
+              (RECORDS READER-ENVIRONMENT)
+              (FUNCTIONS WITH-READER-ENVIRONMENT)
+              (ADDVARS (SYSSPECVARS *PACKAGE* *READTABLE* *READ-BASE* *PRINT-BASE*))
+              (PROP INFO WITH-READER-ENVIRONMENT)
+              (GLOBALVARS *COMMON-LISP-READ-ENVIRONMENT*)
+              (INITVARS (*COMMON-LISP-READ-ENVIRONMENT* (create READER-ENVIRONMENT REPACKAGE _
+                                                               (CL:FIND-PACKAGE "USER")
+                                                               REREADTABLE _ CMLRDTBL REBASE _ 10]
+        (PROP FILETYPE CMLREAD)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT 
+                            CL:READ-CHAR-NO-HANG CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR 
+                            CL:READ-LINE CL:COPY-READTABLE])
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 CL:WRITE-BYTE CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG
+                         CL:LISTEN CL:PEEK-CHAR CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE 
+                         CL:COPY-READTABLE)
+)
+(PUTPROPS CMLREAD COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (3113 4089 (CL:COPY-READTABLE 3123 . 4087)) (4090 10834 (CL:READ-LINE 4100 . 4967) (
+CL:READ-CHAR 4969 . 5534) (CL:UNREAD-CHAR 5536 . 5995) (CL:PEEK-CHAR 5997 . 8003) (CL:LISTEN 8005 . 
+8285) (CL:READ-CHAR-NO-HANG 8287 . 9076) (CL:CLEAR-INPUT 9078 . 9330) (CL:READ-FROM-STRING 9332 . 
+10087) (CL:READ-BYTE 10089 . 10561) (CL:WRITE-BYTE 10563 . 10832)))))
+STOP

CLTL2/CMLREADTABLE

@@ -0,0 +1,156 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "25-Oct-91 16:19:12" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;3
 21290  
+
+      changes to%:  (VARS CMLREADTABLECOMS) (VARIABLES CL:*READ-EVAL*) (FUNCTIONS HASH-DOT)
+
+      previous date%: "15-Aug-91 23:36:53" {DSK}<usr>local>lde>lispcore>sources>CMLREADTABLE.;2)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLREADTABLECOMS)
+
+(RPAQQ CMLREADTABLECOMS ((COMS (* ; "Common Lisp readtable interface functions ") (FUNCTIONS HASH-LEFT-PAD-INITIAL-CONTENTS CL:SET-SYNTAX-FROM-CHAR CL:GET-DISPATCH-MACRO-CHARACTER CL:GET-MACRO-CHARACTER CL:MAKE-DISPATCH-MACRO-CHARACTER CL:SET-DISPATCH-MACRO-CHARACTER CL:SET-MACRO-CHARACTER CL:READTABLE-CASE CL::SET-READTABLE-CASE) (SETFS CL:READTABLE-CASE) (FUNCTIONS DO-DISPATCH-MACRO FIND-MACRO-FUNCTION CL-MACRO-WRAPPED-P CL-UNWRAP-MACRO CL-WRAP-MACRO IL-MACRO-WRAPPED-P IL-UNWRAP-MACRO IL-WRAP-MACRO)) (COMS (* ; "hash macro sub functions") (FUNCTIONS HASH-LEFTPAREN HASH-A HASH-B HASH-BACKSLASH HASH-C HASH-COLON HASH-COMMA HASH-DOT HASH-DOUBLEQUOTE HASH-ILLEGAL-HASH-CHAR HASH-LEFTANGLE HASH-MINUS HASH-NO-PARAMETER-ERROR HASH-O HASH-P HASH-PLUS HASH-QUOTE HASH-R HASH-S HASH-STAR HASH-VBAR HASH-X HASH-EQUAL HASH-NUMBER-SIGN HASH-STRUCTURE-SMASH HASH-STRUCTURE-LOOKUP) (* ; "Temporary") (VARIABLES *READ-SUPPRESS* CL:*READ-EVAL*)) (COMS (* ; "Common Lisp default readtables") (FNS CMLRDTBL INIT-CML-READTABLES SET-DEFAULT-HASHMACRO-SETTINGS CMLREADSEMI) (DECLARE%: DONTEVAL@LOAD DOCOPY (P (INIT-CML-READTABLES)))) (PROP FILETYPE CMLREADTABLE)))
+
+
+
+(* ; "Common Lisp readtable interface functions ")

+
+
+(CL:DEFUN HASH-LEFT-PAD-INITIAL-CONTENTS (SIZE IVAL-LIST) (LET ((PADLENGTH (- SIZE (LENGTH IVAL-LIST)))) (COND ((> PADLENGTH 0) (APPEND IVAL-LIST (CL:MAKE-LIST PADLENGTH :INITIAL-ELEMENT (CAR (LAST IVAL-LIST))))) (T (CL:ERROR "Values list too long for #~D()" SIZE)))))
+
+(CL:DEFUN CL:SET-SYNTAX-FROM-CHAR (TO-CHAR FROM-CHAR &OPTIONAL (TO-READTABLE *READTABLE*) (FROM-READTABLE CMLRDTBL)) (SETSYNTAX (CL:CHAR-CODE TO-CHAR) (GETSYNTAX (CL:CHAR-CODE FROM-CHAR) FROM-READTABLE) TO-READTABLE) T)
+
+(CL:DEFUN CL:GET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR &OPTIONAL (READTABLE *READTABLE*)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (CDR (ASSOC SUB-CHAR (CDR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE))))))
+
+(CL:DEFUN CL:GET-MACRO-CHARACTER (CHAR &OPTIONAL (READTABLE *READTABLE* RTP)) (CL:WHEN (AND RTP (NULL READTABLE)) (SETQ READTABLE (FIND-READTABLE "LISP"))) (* ;;; "insures entry is Common Lisp form - (MACRO {FIRST,ALWAYS} (LAMBDA (STREAM READTABLE) (FUNCALL <function> '<char> STREAM))))") (LET ((TABENTRY (GETSYNTAX (CL:CHAR-CODE CHAR) READTABLE)) NON-TERMINATING-P) (AND (CL:CONSP TABENTRY) (EQ (CAR TABENTRY) (QUOTE MACRO)) (CL:CONSP (CDR TABENTRY)) (FMEMB (CADR TABENTRY) (QUOTE (ALWAYS FIRST))) (SETQ NON-TERMINATING-P (CADR TABENTRY)) (CL:CONSP (SETQ TABENTRY (CDDR TABENTRY))) (NULL (CDR TABENTRY)) (CL:VALUES (FIND-MACRO-FUNCTION (CAR TABENTRY)) (NEQ NON-TERMINATING-P (QUOTE ALWAYS))))))
+
+(CL:DEFUN CL:MAKE-DISPATCH-MACRO-CHARACTER (CHAR &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (LAMBDA (STREAM READTABLE Z) (DO-DISPATCH-MACRO (\, CHAR) STREAM READTABLE)))) READTABLE) T)
+
+(CL:DEFUN CL:SET-DISPATCH-MACRO-CHARACTER (DISP-CHAR SUB-CHAR FUNCTION &OPTIONAL (READTABLE *READTABLE*)) (CL:IF (CL:DIGIT-CHAR-P SUB-CHAR) (CL:ERROR "Digit ~S illegal as a sub-character for a dispatching macro" SUB-CHAR)) (SETQ SUB-CHAR (CL:CHAR-UPCASE SUB-CHAR)) (LET ((DISP-TABLE (OR (ASSOC DISP-CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE)) (LET ((NEWTABLE (LIST DISP-CHAR))) (push (fetch (READTABLEP DISPATCHMACRODEFS) of READTABLE) NEWTABLE) NEWTABLE))) DISP-CONS) (if (SETQ DISP-CONS (ASSOC SUB-CHAR (CDR DISP-TABLE))) then (CL:SETF (CDR DISP-CONS) FUNCTION) else (push (CDR DISP-TABLE) (CONS SUB-CHAR FUNCTION))) T))
+
+(CL:DEFUN CL:SET-MACRO-CHARACTER (CHAR FUNCTION &OPTIONAL NON-TERMINATING (READTABLE *READTABLE*)) (SETSYNTAX (CL:CHAR-CODE CHAR) (BQUOTE (MACRO (\, (CL:IF NON-TERMINATING (QUOTE FIRST) (QUOTE ALWAYS))) (\, (COND ((IL-MACRO-WRAPPED-P FUNCTION) (IL-UNWRAP-MACRO FUNCTION)) (T (CL-WRAP-MACRO FUNCTION CHAR)))))) READTABLE) T)
+
+(CL:DEFUN CL:READTABLE-CASE (CL:READTABLE) (CL:IF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :DOWNCASE :UPCASE) (CL:IF (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) :INVERT :PRESERVE)))
+
+(CL:DEFUN CL::SET-READTABLE-CASE (CL:READTABLE CL::NEW-CASE) (CL:ECASE CL::NEW-CASE (:PRESERVE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:UPCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) NIL)) (:DOWNCASE (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) T (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T)) (:INVERT (CL:SETF (fetch (READTABLEP CASEINSENSITIVE) of CL:READTABLE) NIL (fetch (READTABLEP LOWER/FLIPCASE) of CL:READTABLE) T))) CL::NEW-CASE)
+
+(CL:DEFSETF CL:READTABLE-CASE CL::SET-READTABLE-CASE)
+
+(CL:DEFUN DO-DISPATCH-MACRO (CHAR STREAM RDTBL) (LET ((*READTABLE* RDTBL) (DISP-TABLE (CDR (ASSOC CHAR (fetch (READTABLEP DISPATCHMACRODEFS) of RDTBL)))) INDEX NEXTCHAR) (COND ((NOT DISP-TABLE) (CL:ERROR "~S is not a dispatch macro character" CHAR)) (T (* ; "DISPATCHMACRODEFS is a list of A-lists") (while (DIGITCHARP (SETQ NEXTCHAR (READCCODE STREAM RDTBL))) do (* ; "read the optional numeric arg") (SETQ INDEX (+ (TIMES (OR INDEX 0) 10) (- NEXTCHAR (CHARCODE 0))))) (LET* ((DISP-CHARACTER (CL:CHAR-UPCASE (CL:CODE-CHAR NEXTCHAR))) (DISP-FUNCTION (CDR (ASSOC DISP-CHARACTER DISP-TABLE)))) (if DISP-FUNCTION then (CL:FUNCALL DISP-FUNCTION STREAM DISP-CHARACTER INDEX) else (CL:IF *READ-SUPPRESS* (PROGN (* ; "Attempt to ignore it") (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (CL:ERROR "Undefined dispatch character ~S for dispatch macro character ~S" DISP-CHARACTER CHAR))))))))
+
+(CL:DEFUN FIND-MACRO-FUNCTION (FORM) (COND ((CL-MACRO-WRAPPED-P FORM) (CL-UNWRAP-MACRO FORM)) ((CL:FUNCTIONP FORM) (IL-WRAP-MACRO FORM))))
+
+(CL:DEFUN CL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by CL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (CL:EQUAL (CADR FORM) (QUOTE (STREAM READTABLE Z))) (CL:CONSP (CDDR FORM)) (NULL (CDDDR FORM)) (CL:CONSP (CADDR FORM)) (EQ (CAADDR FORM) (QUOTE CL:FUNCALL))))
+
+(CL:DEFUN CL-UNWRAP-MACRO (FORM) (* ;;; "Fetches CL function out wrapped by CL-WRAP-MACRO") (CADR (CADR (CADDR FORM))))
+
+(CL:DEFUN CL-WRAP-MACRO (FN CHAR) (* ;;; "Wraps a form around a CL readmacro to make it acceptable as an IL readmacro") (BQUOTE (CL:LAMBDA (STREAM READTABLE Z) (CL:FUNCALL (QUOTE (\, FN)) STREAM (\, CHAR)))))
+
+(CL:DEFUN IL-MACRO-WRAPPED-P (FORM) (* ;;; "Predicate that checks for forms built by IL-WRAP-MACRO") (AND (CL:CONSP FORM) (EQ (CAR FORM) (QUOTE CL:LAMBDA)) (CL:CONSP (CDR FORM)) (EQUAL (CADR FORM) (QUOTE (STREAM CHAR))) (CL:CONSP (SETQ FORM (CDDR FORM))) (NULL (CDR FORM)) (CL:CONSP (SETQ FORM (CAR FORM))) (EQ (CAR FORM) (QUOTE CL:FUNCALL)) (EQ (CADDR FORM) (QUOTE STREAM))))
+
+(CL:DEFUN IL-UNWRAP-MACRO (FORM) (CADR (CADR (CADDR FORM))))
+
+(CL:DEFUN IL-WRAP-MACRO (FORM) (* ;;; "Wraps a form around an IL readmacro to make it acceptable as a CL readmacro") (BQUOTE (CL:LAMBDA (STREAM CHAR) (CL:FUNCALL (QUOTE (\, FORM)) STREAM))))
+
+
+
+(* ; "hash macro sub functions")

+
+
+(CL:DEFUN HASH-LEFTPAREN (STREAM CHAR INDEX) (LET ((CONTENTS (CL:READ-DELIMITED-LIST #\) STREAM T))) (COND (*READ-SUPPRESS* NIL) (\INBQUOTE (* ;; "We are inside a back-quote - generate %",(coerce ',contents 'vector)%"") (CL:WHEN INDEX (CL:CERROR "Ignore the explicit length" "Explicit length not allowed in backquoted vectors:~%%#~D~S" INDEX CONTENTS)) (LIST (QUOTE \,) (BQUOTE (COERCE (\, (LIST (QUOTE BQUOTE) CONTENTS)) (QUOTE CL:VECTOR))))) (INDEX (IF (<= (LENGTH CONTENTS) INDEX) THEN (LET ((VEC (CL:MAKE-ARRAY INDEX :INITIAL-ELEMENT (CAR (LAST CONTENTS))))) (LET ((XCL-USER::T0 (LENGTH CONTENTS)) (I 0)) (CL:BLOCK NIL (LET NIL (CL:TAGBODY LOOPTAG0015 (COND ((>= I XCL-USER::T0) (RETURN NIL))) (CL:SETF (CL:AREF VEC I) (POP CONTENTS)) (CL:INCF I) (GO LOOPTAG0015))))) VEC) ELSE (CL:ERROR "Values list too long for #~D()" INDEX))) (T (CL:MAKE-ARRAY (LENGTH CONTENTS) :INITIAL-CONTENTS CONTENTS)))))
+
+(CL:DEFUN HASH-A (STREAM CHAR PARAM) (LET ((CONTENTS (CL:READ STREAM T NIL T))) (COND (*READ-SUPPRESS* NIL) (T (CL:MAKE-ARRAY (ESTIMATE-DIMENSIONALITY PARAM CONTENTS) :INITIAL-CONTENTS CONTENTS)))))
+
+(CL:DEFUN HASH-B (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 2))))
+
+(CL:DEFUN HASH-BACKSLASH (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CHARACTER.READ STREAM) NIL) (T (CL:IF (OR (NULL PARAM) (AND (TYPEP PARAM (QUOTE CL:FIXNUM)) (>= PARAM 0) (< PARAM LISP:CHAR-FONT-LIMIT))) (CHARACTER.READ STREAM) (CL:ERROR "Illegal font specifier ~S for #\" PARAM)))))
+
+(CL:DEFUN HASH-C (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (DESTRUCTURING-BIND (NUM DEN) (CL:READ STREAM T NIL T) (COMPLEX NUM DEN)))))
+
+(CL:DEFUN HASH-COLON (STREAM CHAR PARAM) (* ; "Uninterned symbol.") (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:MAKE-SYMBOL (READ-EXTENDED-TOKEN STREAM *READTABLE* T)))))
+
+(CL:DEFUN HASH-COMMA (STREAM CHAR PARAM) (* ;;; "If the compiler is reading, then wrap up the form in a special data object to be noticed by FASL later.  If it's not the compiler, then treat exactly like #.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) ((NULL CL:*READ-EVAL*) (ERROR "#, encountered on ~S with *READ-EVAL* NIL" STREAM)) (T (CL:WHEN *CLTL2-PEDANTIC* (CL:CERROR "Read it anyway" "#, encountered on ~S with *CLTL2-PEDANTIC* non-NIL" STREAM)) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LET ((FORM (CL:READ STREAM T NIL T))) (IF COMPILER::*COMPILER-IS-READING* THEN (COMPILER::MAKE-EVAL-WHEN-LOAD :FORM FORM) ELSEIF (FETCH (READTABLEP COMMONLISP) OF *READTABLE*) THEN (CL:EVAL FORM) ELSE (EVAL FORM))))))
+
+(CL:DEFUN HASH-DOT (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS CL:*READ-EVAL* (CL:CERROR "Read and eval anyway" "#. with *READ-EVAL* NIL on ~s" STREAM)) (COND ((fetch (READTABLEP COMMONLISP) of *READTABLE*) (CL:EVAL (CL:READ STREAM T NIL T))) (T (EVAL (CL:READ STREAM T NIL T)))))))
+
+(CL:DEFUN HASH-DOUBLEQUOTE (STREAM CHAR PARAM) (* ;;; "An extension to Common Lisp.  This reads a normal string but ignores CR's and any whitespace immediately following them.") (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (RSTRING STREAM *READTABLE* (QUOTE SKIP)))))
+
+(CL:DEFUN HASH-ILLEGAL-HASH-CHAR (STREAM CHAR PARAM) (CL:ERROR "Illegal hash macro character ~S" CHAR))
+
+(CL:DEFUN HASH-LEFTANGLE (STREAM CHAR PARAM) (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:ERROR "Unreadable object #<~A>" (CL:READ STREAM T NIL T)))
+
+(CL:DEFUN HASH-MINUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, when it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:WHEN (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))
+
+(CL:DEFUN HASH-NO-PARAMETER-ERROR (CHAR PARAM) (CL:WHEN PARAM (CL:ERROR "Parameter ~D not allowed with hash macro ~S" PARAM CHAR)))
+
+(CL:DEFUN HASH-O (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 8))))
+
+(CL:DEFUN HASH-P (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (PATHNAME (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-PLUS (STREAM CHAR PARAM) (* ;; "When *READ-SUPPRESS* is true, we want to simply skip over the two forms (the feature expression and the controlled expression).  Otherwise, we read the feature expression and, unless it applies to us, skip over the controlled expression.  In any case, we never return a value.") (COND (*READ-SUPPRESS* (* ; "Skip two forms.") (CL:READ STREAM T NIL T) (CL:READ STREAM T NIL T)) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CL:UNLESS (CMLREAD.FEATURE.PARSER (LET ((*PACKAGE* *KEYWORD-PACKAGE*)) (CL:READ STREAM T NIL T))) (LET ((*READ-SUPPRESS* T)) (CL:READ STREAM T NIL T))))) (CL:VALUES))
+
+(CL:DEFUN HASH-QUOTE (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (LIST (QUOTE CL:FUNCTION) (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-R (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (PARAM (READNUMBERINBASE STREAM PARAM)) (T (CL:ERROR "No base supplied for #R"))))
+
+(CL:DEFUN HASH-S (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (CL:READ STREAM T NIL T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (CREATE-STRUCTURE (CL:READ STREAM T NIL T)))))
+
+(CL:DEFUN HASH-STAR (STREAM CHAR PARAM) (DECLARE (IGNORE CHAR)) (IF (EQ (PEEKC STREAM) (QUOTE %()) THEN (* ; "It's a bitmap.") (IF *READ-SUPPRESS* THEN (CL:READ STREAM NIL NIL T) (CL:READ STREAM NIL NIL T) ELSEIF PARAM THEN (CL:ERROR "Unexpected parameter ~S given in #* bitmap syntax." PARAM) ELSE (FINISH-READING-BITMAP STREAM)) ELSE (* ; "It's a bit-vector.") (LET* ((CONTENTS (READ-EXTENDED-TOKEN STREAM)) (LEN (NCHARS CONTENTS))) (IF *READ-SUPPRESS* THEN NIL ELSEIF (AND (EQ LEN 0) PARAM (NEQ PARAM 0)) THEN (CL:ERROR "No contents specified for bit vector #~A*" PARAM) ELSEIF (AND PARAM (> LEN PARAM)) THEN (CL:ERROR "Bit vector contents longer than specified length in #~A*~A" PARAM CONTENTS) ELSE (LET ((BITARRAY (CL:MAKE-ARRAY (OR PARAM LEN) :ELEMENT-TYPE (QUOTE BIT) :INITIAL-ELEMENT (IF (AND PARAM (> PARAM LEN 0)) THEN (SELCHARQ (NTHCHARCODE CONTENTS -1) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)) ELSE 0)))) (CL:DOTIMES (I LEN) (CL:SETF (CL:AREF BITARRAY I) (SELCHARQ (NTHCHARCODE CONTENTS (CL:1+ I)) (0 0) (1 1) (CL:ERROR "Illegal bit vector element in #~A*~A" PARAM CONTENTS)))) BITARRAY)))))
+
+(CL:DEFUN HASH-VBAR (STREAM CHAR PARAM) (OR *READ-SUPPRESS* (HASH-NO-PARAMETER-ERROR CHAR PARAM)) (LET ((*READ-SUPPRESS* T)) (SKIP.HASH.COMMENT STREAM *READTABLE*) (CL:VALUES)))
+
+(CL:DEFUN HASH-X (STREAM CHAR PARAM) (COND (*READ-SUPPRESS* (READ-EXTENDED-TOKEN STREAM *READTABLE* T) NIL) (T (HASH-NO-PARAMETER-ERROR CHAR PARAM) (READNUMBERINBASE STREAM 16))))
+
+(CL:DEFUN HASH-EQUAL (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* (CL:VALUES) (PROGN (CL:IF (NULL PARAM) (CL:ERROR "#= encountered")) (CL:IF (CL:ASSOC PARAM *CIRCLE-READ-LIST*) (CL:ERROR "#~D= seen twice in same context")) (LET ((NEWNODE (CONS PARAM NIL))) (CL:PUSH NEWNODE *CIRCLE-READ-LIST*) (CL:SETF (CDR NEWNODE) (CL:READ STREAM T NIL T))))))
+
+(CL:DEFUN HASH-NUMBER-SIGN (STREAM CHAR PARAM) (CL:IF *READ-SUPPRESS* NIL (LET ((CIRCLE-PART (CL:ASSOC PARAM *CIRCLE-READ-LIST*))) (COND (CIRCLE-PART) (T (CL:ERROR "#~D# encountered before #~D=" PARAM PARAM))))))
+
+(CL:DEFUN HASH-STRUCTURE-SMASH (THING) (CL:TYPECASE THING (CONS (CL:IF (HASH-STRUCTURE-LOOKUP (CAR THING)) (CL:SETF (CAR THING) (CDAR THING)) (HASH-STRUCTURE-SMASH (CAR THING))) (CL:IF (HASH-STRUCTURE-LOOKUP (CDR THING)) (CL:SETF (CDR THING) (CDDR THING)) (HASH-STRUCTURE-SMASH (CDR THING)))) ((CL:ARRAY T) (LET* ((ASIZE (CL:ARRAY-TOTAL-SIZE THING)) (VARRAY (CL:IF (> (CL:ARRAY-RANK THING) 1) (CL:MAKE-ARRAY ASIZE :DISPLACED-TO THING) THING)) SLOTCONTENTS) (CL:DOTIMES (X ASIZE) (CL:SETQ SLOTCONTENTS (CL:AREF VARRAY X)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (CL:SETF (CL:AREF VARRAY X) (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS))))) (LISP::STRUCTURE-OBJECT (LET (SLOTCONTENTS) (CL:DOLIST (DESCR (LISP::STRUCTURE-POINTER-SLOTS (CL:TYPE-OF THING))) (CL:SETQ SLOTCONTENTS (FETCHFIELD DESCR THING)) (CL:IF (HASH-STRUCTURE-LOOKUP SLOTCONTENTS) (REPLACEFIELD DESCR THING (CDR SLOTCONTENTS)) (HASH-STRUCTURE-SMASH SLOTCONTENTS)))))))
+
+(CL:DEFUN HASH-STRUCTURE-LOOKUP (SLOTCONTENTS) (AND (CL:CONSP SLOTCONTENTS) (MEMQ SLOTCONTENTS *CIRCLE-READ-LIST*)))
+
+
+
+(* ; "Temporary")

+
+
+(CL:DEFVAR *READ-SUPPRESS* NIL)
+
+(CL:DEFVAR CL:*READ-EVAL* T)
+
+
+
+(* ; "Common Lisp default readtables")

+
+(DEFINEQ
+
+(CMLRDTBL

+(LAMBDA NIL (* ; "Edited  3-Apr-91 11:22 by jrb:") (* ;; "Creates a vanilla common-lisp read table") (PROG ((TBL (COPYREADTABLE (QUOTE ORIG)))) (* ;; "First reset the table") (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) TBL)) (* ;; "Install the goodies") (SETSEPR (CHARCODE (SPACE CR ^L LF TAB)) 1 TBL) (SETSYNTAX (CHARCODE "'") (QUOTE (MACRO ALWAYS READQUOTE)) TBL) (* ;; "Note that in cml, most of these macros are terminating, even though it would be nicer for us if they were not") (SETSYNTAX (CHARCODE ";") (QUOTE (MACRO ALWAYS CMLREADSEMI)) TBL) (SETSYNTAX (CHARCODE ")") (QUOTE RIGHTPAREN) TBL) (SETSYNTAX (CHARCODE "(") (QUOTE LEFTPAREN) TBL) (* ;; "These two PROPS == CL:READTABLE-CASE :UPCASE") (READTABLEPROP TBL (QUOTE CASEINSENSITIVE) T) (READTABLEPROP TBL (QUOTE LOWER/FLIPCASE) NIL) (READTABLEPROP TBL (QUOTE COMMONLISP) T) (READTABLEPROP TBL (QUOTE COMMONNUMSYNTAX) T) (READTABLEPROP TBL (QUOTE USESILPACKAGE) NIL) (READTABLEPROP TBL (QUOTE ESCAPECHAR) (CHARCODE "\")) (READTABLEPROP TBL (QUOTE MULTIPLE-ESCAPECHAR) (CHARCODE "|")) (if *PACKAGE* then (READTABLEPROP TBL (QUOTE PACKAGECHAR) (CHARCODE ":"))) (SET-DEFAULT-HASHMACRO-SETTINGS TBL) (SETSYNTAX (CHARCODE %") (QUOTE STRINGDELIM) TBL) (SETSYNTAX (CHARCODE "`") (QUOTE (MACRO ALWAYS READBQUOTE)) TBL) (SETSYNTAX (CHARCODE ",") (QUOTE (MACRO ALWAYS READBQUOTECOMMA)) TBL) (RETURN TBL)))
+)
+
+(INIT-CML-READTABLES

+(LAMBDA NIL (* ; "Edited 16-Jan-87 15:47 by bvm:") (DECLARE (GLOBALVARS CMLRDTBL *COMMON-LISP-READ-ENVIRONMENT* READ-LINE-RDTBL)) (READTABLEPROP (SETQ CMLRDTBL (CMLRDTBL)) (QUOTE NAME) "LISP") (SETQ *COMMON-LISP-READ-ENVIRONMENT* (MAKE-READER-ENVIRONMENT (LISP:FIND-PACKAGE "USER") CMLRDTBL 10)) (LET ((FILETBL (COPYREADTABLE CMLRDTBL))) (* ; "Make one for files that has font indicators as seprs") (for I from 1 to 26 do (SETSYNTAX I (QUOTE SEPRCHAR) FILETBL)) (READTABLEPROP FILETBL (QUOTE NAME) "XCL")) (PROGN (* ; "Read table to make READ-LINE work easily") (SETQ READ-LINE-RDTBL (COPYREADTABLE (QUOTE ORIG))) (for I from 0 to \MAXTHINCHAR do (SETSYNTAX I (QUOTE OTHER) READ-LINE-RDTBL)) (SETBRK (CHARCODE (EOL)) NIL READ-LINE-RDTBL)))
+)
+
+(SET-DEFAULT-HASHMACRO-SETTINGS

+(LAMBDA (RDTBL) (* ; "Edited  3-Apr-91 11:23 by jrb:") (READTABLEPROP RDTBL (QUOTE HASHMACROCHAR) (CHARCODE "#")) (LISP:MAKE-DISPATCH-MACRO-CHARACTER #\# T RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\( (QUOTE HASH-LEFTPAREN) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\' (QUOTE HASH-QUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\. (QUOTE HASH-DOT) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\, (QUOTE HASH-COMMA) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\\ (QUOTE HASH-BACKSLASH) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\* (QUOTE HASH-STAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\: (QUOTE HASH-COLON) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\O (QUOTE HASH-O) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\B (QUOTE HASH-B) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\X (QUOTE HASH-X) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\R (QUOTE HASH-R) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\A (QUOTE HASH-A) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\S (QUOTE HASH-S) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\C (QUOTE HASH-C) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\P (QUOTE HASH-P) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\+ (QUOTE HASH-PLUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\- (QUOTE HASH-MINUS) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\| (QUOTE HASH-VBAR) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\< (QUOTE HASH-LEFTANGLE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\" (QUOTE HASH-DOUBLEQUOTE) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\= (QUOTE HASH-EQUAL) RDTBL) (LISP:SET-DISPATCH-MACRO-CHARACTER #\# #\# (QUOTE HASH-NUMBER-SIGN) RDTBL) RDTBL)
+)
+
+(CMLREADSEMI

+(LAMBDA (STREAM RDTBL) (* bvm%: "13-Oct-86 15:53") (* ;;; "Read and discard through end of line") (until (EQ (READCCODE STREAM) (CHARCODE NEWLINE)) do NIL) (LISP:VALUES))
+)
+)
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(INIT-CML-READTABLES)
+)
+
+(PUTPROPS CMLREADTABLE FILETYPE CL:COMPILE-FILE)
+(PUTPROPS CMLREADTABLE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (17000 21075 (CMLRDTBL 17010 . 18400) (INIT-CML-READTABLES 18402 . 19168) (
+SET-DEFAULT-HASHMACRO-SETTINGS 19170 . 20882) (CMLREADSEMI 20884 . 21073)))))
+STOP

CLTL2/CMLSEQBASICS

@@ -0,0 +1,198 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 14:37:58" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;2"
 10546  
+
+      previous date%: "29-Aug-91 16:36:55" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSEQBASICS.;1"
+)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQBASICSCOMS)
+
+(RPAQQ CMLSEQBASICSCOMS

+       ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON))
+        (FUNCTIONS LISP:CONCATENATE LISP:COPY-SEQ LISP:ELT LISP:LENGTH LISP:MAKE-SEQUENCE 
+               LISP:NREVERSE LISP:REVERSE LISP:SUBSEQ %%SETELT)
+        (FUNCTIONS MAKE-SEQUENCE-OF-TYPE)
+        (SETFS LISP:ELT LISP:SUBSEQ)
+        (PROPS (CMLSEQBASICS FILETYPE))
+        (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(LISP:DEFUN LISP:CONCATENATE
 (RESULT-TYPE &REST SEQUENCES)
+   [LET [(RESULT (MAKE-SEQUENCE-OF-TYPE
 RESULT-TYPE (LET ((CNT 0))
+                                                             (LISP:DOLIST (SEQ SEQUENCES CNT)
+                                                                 (SETQ CNT (+ CNT (LISP:LENGTH

+                                                                                   SEQ))))]
+        (SEQ-DISPATCH RESULT [LET ((TAIL RESULT))
+                                  (LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
+                                      [SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
+                                                                 (RPLACA TAIL ELEMENT)
+                                                                 (SETQ TAIL (CDR TAIL)))
+                                             (LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
+                                                 (RPLACA TAIL (LISP:AREF SEQUENCE I))
+                                                 (SETQ TAIL (CDR TAIL)))])]
+               (LET ((INDEX 0))
+                    (LISP:DOLIST (SEQUENCE SEQUENCES RESULT)
+                        [SEQ-DISPATCH SEQUENCE (LISP:DOLIST (ELEMENT SEQUENCE)
+                                                   (LISP:SETF (LISP:AREF RESULT INDEX)
+                                                          ELEMENT)
+                                                   (SETQ INDEX (LISP:1+ INDEX)))
+                               (LISP:DOTIMES (I (VECTOR-LENGTH SEQUENCE))
+                                   (LISP:SETF (LISP:AREF RESULT INDEX)
+                                          (LISP:AREF SEQUENCE I))
+                                   (SETQ INDEX (LISP:1+ INDEX)))])])
+
+(LISP:DEFUN LISP:COPY-SEQ
 (SEQUENCE)
+   "Returns a copy of SEQUENCE which is EQUALP to SEQUENCE but not EQ."
+   [LET ((LENGTH (LISP:LENGTH
 SEQUENCE)))
+        (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT COPY TAIL)
+                                      COPY
+                                      (COLLECT-ITEM CURRENT COPY TAIL))
+               (LET [(COPY (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
+                    (COPY-VECTOR-SUBSEQ SEQUENCE 0 LENGTH COPY 0 LENGTH])
+
+(LISP:DEFUN LISP:ELT
 (SEQUENCE INDEX)
+                                                             (* amd " 5-Jun-86 17:48")

+   (LISP:IF (NOT (< -1 INDEX (LISP:LENGTH
 SEQUENCE)))
+       (LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
+   (SEQ-DISPATCH SEQUENCE (LISP:NTH INDEX SEQUENCE)
+          (LISP:AREF SEQUENCE INDEX)))
+
+(LISP:DEFUN LISP:LENGTH
 (SEQUENCE)
+   (SEQ-DISPATCH SEQUENCE [LET ((SIZE 0)
+                                (REST SEQUENCE))
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
+                                                 (RETURN SIZE))
+                                      (SETQ REST (CDR REST))
+                                      (SETQ SIZE (LISP:1+ SIZE]
+          (VECTOR-LENGTH SEQUENCE)))
+
+(LISP:DEFUN LISP:MAKE-SEQUENCE
 (TYPE LENGTH &KEY (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P))
+   "Make a sequnce of the specified type"
+   (LISP:IF (EQ TYPE 'LIST)
+       (LISP:MAKE-LIST LENGTH :INITIAL-ELEMENT INITIAL-ELEMENT)
+       (LET ((VECTOR (MAKE-SEQUENCE-OF-TYPE
 TYPE LENGTH)))
+            (LISP:IF INITIAL-ELEMENT-P (FILL-VECTOR-SUBSEQ VECTOR 0 LENGTH INITIAL-ELEMENT))
+            VECTOR)))
+
+(LISP:DEFUN LISP:NREVERSE
 (SEQUENCE)
+   "Returns a sequence of the same elements in reverse order (the argument is destroyed)."
+   [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
+                                LIST-HEAD RESULT)
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP (SETQ LIST-HEAD REST)))
+                                                 (RETURN RESULT))
+                                      (SETQ REST (CDR REST))
+                                      (SETQ RESULT (RPLACD LIST-HEAD RESULT]
+          (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
+               (LISP:DO ((LEFT-INDEX 0 (LISP:1+ LEFT-INDEX))
+                         (RIGHT-INDEX (LISP:1- LENGTH)
+                                (LISP:1- RIGHT-INDEX))
+                         (HALF-LENGTH (LRSH LENGTH 1)))
+                        ((EQL LEFT-INDEX HALF-LENGTH)
+                         SEQUENCE)
+                   (LISP:ROTATEF (LISP:AREF SEQUENCE LEFT-INDEX)
+                          (LISP:AREF SEQUENCE RIGHT-INDEX)))])
+
+(LISP:DEFUN LISP:REVERSE
 (SEQUENCE)
+   "Returns a new sequence containing the same elements but in reverse order."
+   [SEQ-DISPATCH SEQUENCE [LET ((REST SEQUENCE)
+                                RESULT)
+                               (LISP:LOOP (LISP:IF (NOT (LISP:CONSP REST))
+                                                 (RETURN RESULT))
+                                      (LISP:PUSH (CAR REST)
+                                             RESULT)
+                                      (SETQ REST (CDR REST]
+          (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)))
+               (LISP:DO ((RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (LISP:ARRAY-ELEMENT-TYPE SEQUENCE)
+                                        ))
+                         (FORWARD-INDEX 0 (LISP:1+ FORWARD-INDEX))
+                         (BACKWARD-INDEX (LISP:1- LENGTH)
+                                (LISP:1- BACKWARD-INDEX)))
+                        ((EQL FORWARD-INDEX LENGTH)
+                         RESULT)
+                   (LISP:SETF (LISP:AREF RESULT FORWARD-INDEX)
+                          (LISP:AREF SEQUENCE BACKWARD-INDEX)))])
+
+(LISP:DEFUN LISP:SUBSEQ
 (SEQUENCE START &OPTIONAL END)
+   [LET ((LENGTH (LISP:LENGTH
 SEQUENCE)))
+        (LISP:IF (NULL END)
+               (SETQ END LENGTH))
+        (CHECK-SUBSEQ SEQUENCE START END LENGTH)
+        (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT COPY TAIL)
+                                      COPY
+                                      (COLLECT-ITEM CURRENT COPY TAIL))
+               (LET [(COPY (MAKE-VECTOR (- END START)
+                                  :ELEMENT-TYPE
+                                  (LISP:ARRAY-ELEMENT-TYPE SEQUENCE]
+                    (COPY-VECTOR-SUBSEQ SEQUENCE START END COPY 0])
+
+(LISP:DEFUN %%SETELT
 (SEQUENCE INDEX NEWVAL)
+   (LISP:IF (NOT (< -1 INDEX (LISP:LENGTH
 SEQUENCE)))
+       (LISP:ERROR 'INDEX-BOUNDS-ERROR :NAME SEQUENCE :INDEX INDEX))
+   (SEQ-DISPATCH SEQUENCE (LISP:SETF (LISP:NTH INDEX SEQUENCE)
+                                 NEWVAL)
+          (LISP:SETF (LISP:AREF SEQUENCE INDEX)
+                 NEWVAL)))
+
+(LISP:DEFUN MAKE-SEQUENCE-OF-TYPE
 (TYPE LENGTH)
+   [LET ((BROAD-TYPE (TYPE-SPECIFIER TYPE))
+         TYPE-LENGTH)
+        (LISP:IF (EQ BROAD-TYPE 'LIST)
+            (LISP:MAKE-LIST LENGTH)
+            [LET [(ELEMENT-TYPE (CASE BROAD-TYPE
+                                    ((LISP:SIMPLE-STRING STRING) 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       'LISP:STRING-CHAR)
+                                    ((LISP:SIMPLE-BIT-VECTOR LISP:BIT-VECTOR) 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       'BIT)
+                                    (LISP:SIMPLE-VECTOR 
+                                       (SETQ TYPE-LENGTH (AND (LISP:CONSP TYPE)
+                                                              (LISP:SECOND TYPE)))
+                                       T)
+                                    ((LISP:ARRAY LISP:VECTOR LISP:SIMPLE-ARRAY) 
+                                       (LISP:IF (LISP:CONSP TYPE)
+                                           (LET ((ELT-TYPE (CADR TYPE)))
+                                                (SETQ TYPE-LENGTH (LISP:THIRD TYPE))
+                                                (LISP:IF (LISP:CONSP TYPE-LENGTH)
+                                                    (SETQ TYPE-LENGTH (CAR TYPE-LENGTH)))
+                                                (LISP:IF [AND ELT-TYPE (NOT (EQ ELT-TYPE 'LISP:*]
+                                                    ELT-TYPE
+                                                    T))
+                                           T)))]
+                 (LISP:IF (AND (LISP:INTEGERP TYPE-LENGTH)
+                               (NOT (EQUAL TYPE-LENGTH LENGTH)))
+                        (LISP:ERROR "~D is not the length of type ~s" LENGTH TYPE))
+                 (LISP:IF ELEMENT-TYPE
+                     (MAKE-VECTOR LENGTH :ELEMENT-TYPE ELEMENT-TYPE)
+                     (LET ((EXPANDER (LISP::TYPE-EXPANDER BROAD-TYPE)))
+                          (LISP:IF EXPANDER
+                              (MAKE-SEQUENCE-OF-TYPE
 (LISP::TYPE-EXPAND TYPE EXPANDER)
+                                     LENGTH)
+                              (LISP:ERROR "~S is a bad type specifier for sequences." TYPE))))])])
+
+(LISP:DEFSETF LISP:ELT
 %%SETELT)
+
+(LISP:DEFSETF LISP:SUBSEQ
 (SEQUENCE START &OPTIONAL END) (NEW-SEQUENCE)
+   `(PROGN (LISP:REPLACE ,SEQUENCE ,NEW-SEQUENCE :START1 ,START :END1 ,END)
+           ,NEW-SEQUENCE))
+
+(PUTPROPS CMLSEQBASICS
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQBASICS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLSEQCOMMON

@@ -0,0 +1,53 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
+
(FILECREATED " 6-Sep-91 14:19:03" {DSK}<new>venue>sources>CMLSEQCOMMON.;3
 5402   
+
+      changes to%:  (OPTIMIZERS CL:COMPLEMENT) (VARS CMLSEQCOMMONCOMS) (FUNCTIONS CL:COMPLEMENT)
+
+      previous date%: "16-May-90 14:28:05" {DSK}<new>sources>lispcore>sources>CMLSEQCOMMON.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQCOMMONCOMS)
+
+(RPAQQ CMLSEQCOMMONCOMS ((FUNCTIONS CHECK-SUBSEQ COLLECT-ITEM COPY-VECTOR-SUBSEQ FILL-VECTOR-SUBSEQ MAKE-SEQUENCE-LIKE SEQ-DISPATCH TYPE-SPECIFIER) (FUNCTIONS BACKWARD-LIST-LOOP BACKWARD-VECTOR-LOOP FORWARD-LIST-LOOP FORWARD-VECTOR-LOOP) (FUNCTIONS CL:COMPLEMENT) (OPTIMIZERS CL:COMPLEMENT) (PROP FILETYPE CMLSEQCOMMON) (DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD (LOCALVARS . T))))
+
+(DEFMACRO CHECK-SUBSEQ (SEQ START END LENGTH) (BQUOTE (CL:IF (NOT (<= 0 (\, START) (\, END) (\, LENGTH))) (CL:ERROR "Illegal subsequence for ~S.~%%Start is ~D. End is ~D" (\, SEQ) (\, START) (\, END)))))
+
+(DEFMACRO COLLECT-ITEM (ITEM HEAD TAIL) (BQUOTE (CL:IF (\, TAIL) (RPLACD (\, TAIL) (SETQ (\, TAIL) (LIST (\, ITEM)))) (SETQ (\, HEAD) (SETQ (\, TAIL) (LIST (\, ITEM)))))))
+
+(DEFMACRO COPY-VECTOR-SUBSEQ (FROM-VECTOR START-FROM END-FROM TO-VECTOR START-TO END-TO) "Copy one vector subsequence to another" (BQUOTE (CL:DO ((FROM-INDEX (\, START-FROM) (CL:1+ FROM-INDEX)) (TO-INDEX (\, START-TO) (CL:1+ TO-INDEX))) ((\, (CL:IF END-FROM (BQUOTE (EQL FROM-INDEX (\, END-FROM))) (BQUOTE (EQL TO-INDEX (\, END-TO))))) (\, TO-VECTOR)) (CL:SETF (CL:AREF (\, TO-VECTOR) TO-INDEX) (CL:AREF (\, FROM-VECTOR) FROM-INDEX)))))
+
+(DEFMACRO FILL-VECTOR-SUBSEQ (VECTOR START END NEWVALUE) (BQUOTE (CL:DO ((INDEX (\, START) (CL:1+ INDEX))) ((EQL INDEX (\, END)) (\, VECTOR)) (CL:SETF (CL:AREF (\, VECTOR) INDEX) (\, NEWVALUE)))))
+
+(DEFMACRO MAKE-SEQUENCE-LIKE (SEQUENCE LENGTH) "Returns a sequence of the same type as SEQUENCE and the given LENGTH." (BQUOTE (LET ((SEQ (\, SEQUENCE))) (CL:ETYPECASE SEQ (LIST (CL:MAKE-LIST (\, LENGTH))) (STRING (CL:MAKE-STRING (\, LENGTH))) (CL:VECTOR (MAKE-VECTOR (\, LENGTH) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQ)))))))
+
+(DEFMACRO SEQ-DISPATCH (SEQUENCE LIST-FORM VECTOR-FORM) (BQUOTE (CL:ETYPECASE (\, SEQUENCE) (LIST (\, LIST-FORM)) (CL:VECTOR (\, VECTOR-FORM)))))
+
+(DEFMACRO TYPE-SPECIFIER (TYPE) "Returns the broad class of which TYPE is a specific subclass." (BQUOTE (CL:IF (CL:ATOM (\, TYPE)) (\, TYPE) (CAR (\, TYPE)))))
+
+(DEFMACRO BACKWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) %%SUBSEQ (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ %%SUBSEQ (CL:NTHCDR (\, INDEX-VAR) (\, SEQUENCE))) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))
+
+(DEFMACRO BACKWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (CL:1- (\, END)) (CL:1- (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((< (\, INDEX-VAR) (\, START)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))
+
+(DEFMACRO FORWARD-LIST-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO ((%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) ((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CAR %%SUBSEQ)) (\,@ BODY)))))
+
+(DEFMACRO FORWARD-VECTOR-LOOP (SEQUENCE START END LOCAL-VARS RETURN-FORM &REST BODY) "Canonical forward loop for vectors" (LET ((INDEX-VAR (CAR LOCAL-VARS)) (CURRENT-ELEMENT-VAR (CADR LOCAL-VARS)) (OTHER-VARS (CDDR LOCAL-VARS))) (BQUOTE (CL:DO (((\, INDEX-VAR) (\, START) (CL:1+ (\, INDEX-VAR))) (\, CURRENT-ELEMENT-VAR) (\,@ OTHER-VARS)) ((EQL (\, INDEX-VAR) (\, END)) (\, RETURN-FORM)) (SETQ (\, CURRENT-ELEMENT-VAR) (CL:AREF (\, SEQUENCE) (\, INDEX-VAR))) (\,@ BODY)))))
+
+(CL:DEFUN CL:COMPLEMENT (CL::FN) (CL:FUNCTION (CL:LAMBDA (&REST CL::ARGUMENTS) (NOT (CL:APPLY CL::FN CL::ARGUMENTS)))))
+
+(DEFOPTIMIZER CL:COMPLEMENT (CL::FN &ENVIRONMENT CL::ENV) (* ;; "If we can find the argument list for FN and it's a simple one (it will be 99%% of the time), we can build a decent COMPLEMENT that doesn't do the extra &REST and APPLY") (LET (CL::FN-NAME CL::FN-ARG-LIST) (CL:IF (AND (CL:CONSP CL::FN) (OR (EQ (CAR CL::FN) (QUOTE QUOTE)) (EQ (CAR CL::FN) (QUOTE CL:FUNCTION))) (CL:SYMBOLP (CL:SETQ CL::FN-NAME (CADR CL::FN))) (CL:CONSP (CL:SETQ CL::FN-ARG-LIST (CAR (NLSETQ (SMARTARGLIST CL::FN-NAME)))))) (BQUOTE (CL:FUNCTION (CL:LAMBDA (\, CL::FN-ARG-LIST) (NOT ((\, CL::FN-NAME) (\,@ CL::FN-ARG-LIST)))))) (QUOTE COMPILER:PASS))))
+
+(PUTPROPS CMLSEQCOMMON FILETYPE CL:COMPILE-FILE)
+(DECLARE%: EVAL@COMPILE DONTCOPY DONTEVAL@LOAD 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQCOMMON COPYRIGHT ("Venue & Xerox Corporation" 1986 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLSEQMAPPERS

@@ -0,0 +1,115 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "29-Aug-91 16:51:48" {DSK}<new>sources>lispcore>sources>CMLSEQMAPPERS.;2
 14225  
+
+      changes to%:  (FUNCTIONS REDUCE-FROM-END REDUCE-FROM-START CL:REDUCE)
+
+      previous date%: "16-May-90 14:31:36" {DSK}<new>sources>lispcore>sources>CMLSEQMAPPERS.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQMAPPERSCOMS)
+
+(RPAQQ CMLSEQMAPPERSCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS %%FILL-SLICE %%MAP-FOR-EFFECT %%MAP-FOR-EFFECT-MULTIPLE %%MAP-FOR-EFFECT-SINGLE %%MAP-FOR-RESULT-MULTIPLE %%MAP-FOR-RESULT-SINGLE %%MIN-SEQUENCE-LENGTH CL:MAP) (* ;; "For compatibility with old optimizers") (FUNCTIONS %%MAP-SINGLE-FOR-EFFECT %%MAP-SINGLE-TO-LIST %%MAP-SINGLE-TO-SIMPLE %%MAP-TO-LIST %%MAP-TO-SIMPLE) (OPTIMIZERS CL:MAP) (FUNCTIONS %%SOME-MULTIPLE %%SOME-SINGLE %%EVERY-MULTIPLE %%EVERY-SINGLE %%NOTANY-MULTIPLE %%NOTANY-SINGLE %%NOTEVERY-MULTIPLE %%NOTEVERY-SINGLE CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (* ;; "For compatibility with old optimizers") (P (MOVD (QUOTE %%SOME-SINGLE) (QUOTE %%SINGLE-SOME)) (MOVD (QUOTE %%EVERY-SINGLE) (QUOTE %%SINGLE-EVERY)) (MOVD (QUOTE %%NOTEVERY-SINGLE) (QUOTE %%SINGLE-NOTEVERY)) (MOVD (QUOTE %%NOTANY-SINGLE) (QUOTE %%SINGLE-NOTANY))) (OPTIMIZERS CL:SOME CL:EVERY CL:NOTANY CL:NOTEVERY) (FUNCTIONS REDUCE-FROM-END REDUCE-FROM-START CL:REDUCE) (PROP FILETYPE CMLSEQMAPPERS) (DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(DEFMACRO %%FILL-SLICE (INDEX SLICE SEQUENCES) (BQUOTE (CL:DO ((%%SUBSLICE (\, SLICE) (CDR %%SUBSLICE)) (%%SUBSEQ (\, SEQUENCES) (CDR %%SUBSEQ)) %%SEQUENCE) ((NULL %%SUBSEQ) (\, SLICE)) (SETQ %%SEQUENCE (CAR %%SUBSEQ)) (RPLACA %%SUBSLICE (SEQ-DISPATCH %%SEQUENCE (PROG1 (CAR %%SEQUENCE) (RPLACA %%SUBSEQ (CDR %%SEQUENCE))) (CL:AREF %%SEQUENCE (\, INDEX)))))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT-MULTIPLE (FUNCTION SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (I MIN-LENGTH) (CL:APPLY FUNCTION (%%FILL-SLICE I ELT-SLICE SEQUENCES)))))
+
+(CL:DEFUN %%MAP-FOR-EFFECT-SINGLE (FUNCTION SEQUENCE) (SEQ-DISPATCH SEQUENCE (CL:DOLIST (ELT SEQUENCE) (CL:FUNCALL FUNCTION ELT)) (CL:DOTIMES (I (VECTOR-LENGTH SEQUENCE)) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE I)))))
+
+(CL:DEFUN %%MAP-FOR-RESULT-MULTIPLE (RESULT-TYPE FUNCTION SEQUENCES) (LET* ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES))) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE MIN-LENGTH))) (SEQ-DISPATCH RESULT (CL:DO ((SUBRESULT RESULT (CDR SUBRESULT)) (INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (RPLACA SUBRESULT (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) RESULT) (CL:SETF (CL:AREF RESULT INDEX) (CL:APPLY FUNCTION (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)))))))
+
+(CL:DEFUN %%MAP-FOR-RESULT-SINGLE (RESULT-TYPE FUNCTION SEQUENCE) (LET* ((LENGTH (CL:LENGTH SEQUENCE)) (RESULT (MAKE-SEQUENCE-OF-TYPE RESULT-TYPE LENGTH))) (SEQ-DISPATCH SEQUENCE (SEQ-DISPATCH RESULT (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (SUBRESULT RESULT (CDR SUBRESULT))) ((NULL SUBSEQ)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CAR SUBSEQ)))) (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (INDEX 0 (CL:1+ INDEX))) ((NULL SUBSEQ)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CAR SUBSEQ))))) (SEQ-DISPATCH RESULT (CL:DO ((INDEX 0 (CL:1+ INDEX)) (SUBRESULT RESULT (CDR SUBRESULT))) ((EQL INDEX LENGTH)) (RPLACA SUBRESULT (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX LENGTH)) (CL:SETF (CL:AREF RESULT INDEX) (CL:FUNCALL FUNCTION (CL:AREF SEQUENCE INDEX)))))) RESULT))
+
+(DEFMACRO %%MIN-SEQUENCE-LENGTH (SEQUENCES) (BQUOTE (CL:DO ((MIN-LENGTH (CL:LENGTH (CAR (\, SEQUENCES)))) (SUBSEQ (CDR (\, SEQUENCES)) (CDR SUBSEQ)) NEXT-LENGTH) ((NULL SUBSEQ) MIN-LENGTH) (SETQ NEXT-LENGTH (CL:LENGTH (CAR SUBSEQ))) (CL:IF (< NEXT-LENGTH MIN-LENGTH) (SETQ MIN-LENGTH NEXT-LENGTH)))))
+
+(CL:DEFUN CL:MAP (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) "FUNCTION must take as many arguments as there are sequences provided.  The result is a sequence such that element i is the result of applying FUNCTION to element i of each of the argument sequences." (CL:IF (NULL RESULT-TYPE) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-MULTIPLE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES)))))
+
+
+
+(* ;; "For compatibility with old optimizers")

+
+
+(CL:DEFUN %%MAP-SINGLE-FOR-EFFECT (FUNCTION SEQUENCE) (%%MAP-FOR-EFFECT-SINGLE FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-SINGLE-TO-LIST (FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE (QUOTE LIST) FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-SINGLE-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE))
+
+(CL:DEFUN %%MAP-TO-LIST (FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE (QUOTE LIST) FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE (QUOTE LIST) FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN %%MAP-TO-SIMPLE (RESULT-TYPE FUNCTION SEQUENCE &REST MORE-SEQUENCES) (CL:IF (NULL MORE-SEQUENCES) (%%MAP-FOR-RESULT-SINGLE RESULT-TYPE FUNCTION SEQUENCE) (%%MAP-FOR-RESULT-MULTIPLE RESULT-TYPE FUNCTION (CONS SEQUENCE MORE-SEQUENCES))))
+
+(DEFOPTIMIZER CL:MAP (RESULT-TYPE FUNCTION FIRST-SEQUNCE &REST MORE-SEQUENCES) (CL:IF (AND (NULL MORE-SEQUENCES) (CL:CONSTANTP RESULT-TYPE)) (CL:IF (NULL (EVAL RESULT-TYPE)) (BQUOTE (%%MAP-FOR-EFFECT-SINGLE (\, FUNCTION) (\, FIRST-SEQUNCE))) (BQUOTE (%%MAP-FOR-RESULT-SINGLE (\, RESULT-TYPE) (\, FUNCTION) (\, FIRST-SEQUNCE)))) (QUOTE COMPILER:PASS)))
+
+(CL:DEFUN %%SOME-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DO ((INDEX 0 (CL:1+ INDEX)) PREDICATE-RESULT) ((EQL INDEX MIN-LENGTH)) (SETQ PREDICATE-RESULT (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT)))))
+
+(CL:DEFUN %%SOME-SINGLE (PREDICATE SEQUENCE) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT))) (FORWARD-VECTOR-LOOP SEQUENCE 0 LENGTH (INDEX CURRENT PREDICATE-RESULT) NIL (SETQ PREDICATE-RESULT (CL:FUNCALL PREDICATE CURRENT)) (CL:IF PREDICATE-RESULT (RETURN PREDICATE-RESULT))))))
+
+(CL:DEFUN %%EVERY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN NIL)))))
+
+(CL:DEFUN %%EVERY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN NIL))) (CL:DOTIMES (INDEX (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE INDEX))) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTANY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH T) (CL:IF (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES)) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTANY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE T) (CL:IF (CL:FUNCALL PREDICATE ELT) (RETURN NIL))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE) T) (CL:IF (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I)) (RETURN NIL)))))
+
+(CL:DEFUN %%NOTEVERY-MULTIPLE (PREDICATE SEQUENCES) (LET ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH SEQUENCES)))) (CL:DOTIMES (INDEX MIN-LENGTH) (CL:IF (NULL (CL:APPLY PREDICATE (%%FILL-SLICE INDEX ELT-SLICE SEQUENCES))) (RETURN T)))))
+
+(CL:DEFUN %%NOTEVERY-SINGLE (PREDICATE FIRST-SEQUENCE) (SEQ-DISPATCH FIRST-SEQUENCE (CL:DOLIST (ELT FIRST-SEQUENCE) (CL:IF (NULL (CL:FUNCALL PREDICATE ELT)) (RETURN T))) (CL:DOTIMES (I (VECTOR-LENGTH FIRST-SEQUENCE)) (CL:IF (NULL (CL:FUNCALL PREDICATE (CL:AREF FIRST-SEQUENCE I))) (RETURN T)))))
+
+(CL:DEFUN CL:SOME (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  SOME returns the first non-() value encountered, or () if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%SOME-SINGLE PREDICATE FIRST-SEQUENCE) (%%SOME-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:EVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  EVERY returns () as soon as any invocation of PREDICATE returns (), or T if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%EVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%EVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:NOTANY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  NOTANY returns () as soon as any invocation of PREDICATE returns a non-() value, or T if the end of a sequence is reached." (CL:IF (NULL MORE-SEQUENCES) (%%NOTANY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTANY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+(CL:DEFUN CL:NOTEVERY (PREDICATE FIRST-SEQUENCE &REST MORE-SEQUENCES) "PREDICATE is applied to the elements with index 0 of the sequences, then possibly to those with index 1, and so on.  NOTEVERY returns T as soon as any invocation of PREDICATE returns (), or () if every invocation is non-()." (CL:IF (NULL MORE-SEQUENCES) (%%NOTEVERY-SINGLE PREDICATE FIRST-SEQUENCE) (%%NOTEVERY-MULTIPLE PREDICATE (CONS FIRST-SEQUENCE MORE-SEQUENCES))))
+
+
+
+(* ;; "For compatibility with old optimizers")

+
+
+(MOVD (QUOTE %%SOME-SINGLE) (QUOTE %%SINGLE-SOME))
+
+(MOVD (QUOTE %%EVERY-SINGLE) (QUOTE %%SINGLE-EVERY))
+
+(MOVD (QUOTE %%NOTEVERY-SINGLE) (QUOTE %%SINGLE-NOTEVERY))
+
+(MOVD (QUOTE %%NOTANY-SINGLE) (QUOTE %%SINGLE-NOTANY))
+
+(DEFOPTIMIZER CL:SOME (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%SOME-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:EVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%EVERY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:NOTANY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%NOTANY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(DEFOPTIMIZER CL:NOTEVERY (PREDICATE SEQUENCE &REST MORE-SEQUENCES) (COND ((NULL MORE-SEQUENCES) (BQUOTE (%%NOTEVERY-SINGLE (\, PREDICATE) (\, SEQUENCE)))) (T (QUOTE COMPILER:PASS))))
+
+(CL:DEFUN REDUCE-FROM-END (FUNCTION SEQUENCE START END INITIAL-VALUE &OPTIONAL KEY) "Backward reduction" (CL:IF KEY (SEQ-DISPATCH SEQUENCE (BACKWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION (CL:FUNCALL KEY CURRENT) ACCUMULATOR))) (BACKWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION (CL:FUNCALL KEY CURRENT) ACCUMULATOR)))) (SEQ-DISPATCH SEQUENCE (BACKWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR))) (BACKWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION CURRENT ACCUMULATOR))))))
+
+(CL:DEFUN REDUCE-FROM-START (FUNCTION SEQUENCE START END INITIAL-VALUE &OPTIONAL KEY) (CL:IF KEY (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR (CL:FUNCALL KEY CURRENT)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR (CL:FUNCALL KEY CURRENT))))) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (ACCUMULATOR INITIAL-VALUE)) ACCUMULATOR (SETQ ACCUMULATOR (CL:FUNCALL FUNCTION ACCUMULATOR CURRENT))))))
+
+(CL:DEFUN CL:REDUCE (FUNCTION SEQUENCE &KEY (START 0) END FROM-END (INITIAL-VALUE NIL INITIAL-VALUE-P) (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF INITIAL-VALUE-P (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START END INITIAL-VALUE (AND KEY-P KEY)) (REDUCE-FROM-START FUNCTION SEQUENCE START END INITIAL-VALUE (AND KEY-P KEY))) (CASE (- END START) (0 (CL:FUNCALL FUNCTION)) (1 (CL:FUNCALL KEY (CL:ELT SEQUENCE START))) (T (CL:IF FROM-END (REDUCE-FROM-END FUNCTION SEQUENCE START (CL:1- END) (CL:FUNCALL KEY (CL:ELT SEQUENCE (CL:1- END))) (AND KEY-P KEY)) (REDUCE-FROM-START FUNCTION SEQUENCE (CL:1+ START) END (CL:FUNCALL KEY (CL:ELT SEQUENCE START)) (AND KEY-P KEY))))))))
+
+(PUTPROPS CMLSEQMAPPERS FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DONTCOPY DOEVAL@COMPILE 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQMAPPERS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLSEQMODIFY

@@ -0,0 +1,143 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "29-Aug-91 16:38:18" {DSK}<new>sources>lispcore>sources>CMLSEQMODIFY.;2
 34278  
+
+      changes to%:  (VARS CMLSEQMODIFYCOMS) (FUNCTIONS CL:MAP-INTO CL::MAP-INTO-SINGLE CL::MAP-INTO-MULTIPLE)
+
+      previous date%: "16-May-90 14:33:28" {DSK}<new>sources>lispcore>sources>CMLSEQMODIFY.;1)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSEQMODIFYCOMS)
+
+(RPAQQ CMLSEQMODIFYCOMS ((DECLARE%: EVAL@COMPILE DONTCOPY (FILES CMLSEQCOMMON)) (FUNCTIONS CL:FILL CL:REPLACE) (FUNCTIONS %%DESTRUCTIVE-RESULT-VECTOR) (FUNCTIONS SIMPLE-REMOVE-MACRO SIMPLE-REMOVE SIMPLE-REMOVE-IF SIMPLE-REMOVE-IF-NOT COMPLEX-REMOVE-MACRO COMPLEX-REMOVE COMPLEX-REMOVE-IF COMPLEX-REMOVE-IF-NOT CL:REMOVE CL:REMOVE-IF CL:REMOVE-IF-NOT) (FUNCTIONS SIMPLE-DELETE-MACRO SIMPLE-DELETE SIMPLE-DELETE-IF SIMPLE-DELETE-IF-NOT COMPLEX-DELETE-MACRO COMPLEX-DELETE COMPLEX-DELETE-IF COMPLEX-DELETE-IF-NOT CL:DELETE CL:DELETE-IF CL:DELETE-IF-NOT) (FUNCTIONS SIMPLE-REMOVE-DUPLICATES COMPLEX-REMOVE-DUPLICATES CL:REMOVE-DUPLICATES) (FUNCTIONS SIMPLE-DELETE-DUPLICATES COMPLEX-DELETE-DUPLICATES CL:DELETE-DUPLICATES) (FUNCTIONS SIMPLE-SUBSTITUTE-MACRO SIMPLE-SUBSTITUTE SIMPLE-SUBSTITUTE-IF SIMPLE-SUBSTITUTE-IF-NOT COMPLEX-SUBSTITUTE-MACRO COMPLEX-SUBSTITUTE COMPLEX-SUBSTITUTE-IF COMPLEX-SUBSTITUTE-IF-NOT CL:SUBSTITUTE CL:SUBSTITUTE-IF CL:SUBSTITUTE-IF-NOT) (FUNCTIONS SIMPLE-NSUBSTITUTE-MACRO SIMPLE-NSUBSTITUTE SIMPLE-NSUBSTITUTE-IF SIMPLE-NSUBSTITUTE-IF-NOT COMPLEX-NSUBSTITUTE-MACRO COMPLEX-NSUBSTITUTE COMPLEX-NSUBSTITUTE-IF COMPLEX-NSUBSTITUTE-IF-NOT CL:NSUBSTITUTE CL:NSUBSTITUTE-IF CL:NSUBSTITUTE-IF-NOT) (FUNCTIONS CL:MAP-INTO CL::MAP-INTO-SINGLE CL::MAP-INTO-MULTIPLE) (PROP FILETYPE CMLSEQMODIFY) (DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE (LOCALVARS . T))))
+(DECLARE%: EVAL@COMPILE DONTCOPY 
+
+(FILESLOAD CMLSEQCOMMON)
+)
+
+(CL:DEFUN CL:FILL (SEQUENCE ITEM &KEY (START 0) END) "Replace the specified elements of SEQUENCE with ITEM." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (SEQ-DISPATCH SEQUENCE (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT) SEQUENCE (RPLACA %%SUBSEQ ITEM)) (FILL-VECTOR-SUBSEQ SEQUENCE START END ITEM))))
+
+(CL:DEFUN CL:REPLACE (SEQUENCE1 SEQUENCE2 &KEY (START1 0) END1 (START2 0) END2) (LET ((LENGTH1 (CL:LENGTH SEQUENCE1)) (LENGTH2 (CL:LENGTH SEQUENCE2))) (CL:IF (NULL END1) (SETQ END1 LENGTH1)) (CL:IF (NULL END2) (SETQ END2 LENGTH2)) (CHECK-SUBSEQ SEQUENCE1 START1 END1 LENGTH1) (CHECK-SUBSEQ SEQUENCE2 START2 END2 LENGTH2) (LET ((SUBLEN1 (- END1 START1)) (SUBLEN2 (- END2 START2))) (* ; "Make equal length") (CL:IF (< SUBLEN1 SUBLEN2) (SETQ END2 (+ START2 SUBLEN1)) (SETQ END1 (+ START1 SUBLEN2))) (* ; "Check for overlap") (CL:WHEN (AND (EQ SEQUENCE1 SEQUENCE2) (> START1 START2) (< START1 END2)) (SETQ SEQUENCE2 (CL:SUBSEQ SEQUENCE2 START2 END2)) (SETQ START2 0) (SETQ END2 (- END2 START2))) (SEQ-DISPATCH SEQUENCE1 (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CAR SUBSEQ2))) (CL:DO ((SUBSEQ1 (CL:NTHCDR START1 SEQUENCE1) (CDR SUBSEQ1)) (INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (RPLACA SUBSEQ1 (CL:AREF SEQUENCE2 INDEX2)))) (SEQ-DISPATCH SEQUENCE2 (CL:DO ((SUBSEQ2 (CL:NTHCDR START2 SEQUENCE2) (CDR SUBSEQ2)) (INDEX1 START1 (CL:1+ INDEX1))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CAR SUBSEQ2))) (CL:DO ((INDEX1 START1 (CL:1+ INDEX1)) (INDEX2 START2 (CL:1+ INDEX2))) ((EQL INDEX1 END1)) (CL:SETF (CL:AREF SEQUENCE1 INDEX1) (CL:AREF SEQUENCE2 INDEX2))))) SEQUENCE1)))
+
+(CL:DEFUN %%DESTRUCTIVE-RESULT-VECTOR (VECTOR START) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P VECTOR) VECTOR (LET ((RESULT (CL:MAKE-ARRAY (VECTOR-LENGTH VECTOR) :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE VECTOR) :FILL-POINTER T))) (COPY-VECTOR VECTOR RESULT :END1 START))))
+
+(DEFMACRO SIMPLE-REMOVE-MACRO (SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (\, TEST-FORM)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE)) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((NOT (\, TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))))
+
+(CL:DEFUN SIMPLE-REMOVE (ITEM SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (EQL ITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-REMOVE-IF (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-REMOVE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-REMOVE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (COLLECT-ITEM CURRENT NEW-LIST TAIL)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST) NEW-LIST (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:PUSH CURRENT NEW-LIST)) (T (CL:INCF NUMBER-OF-MATCHES))))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE)) :FILL-POINTER T))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (RESULT-INDEX (\, START))) NIL (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (RESULT-INDEX (CL:1- (\, END)))) (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ (\, START) NUMBER-OF-MATCHES) (\, END) RESULT (\, START) (- (\, END) NUMBER-OF-MATCHES))) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:DECF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))))
+
+(CL:DEFUN COMPLEX-REMOVE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-REMOVE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-REMOVE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-REMOVE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:REMOVE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-REMOVE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE ITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:REMOVE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:REMOVE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-REMOVE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-REMOVE-IF-NOT TEST SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-DELETE-MACRO (SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((HANDLE (CONS NIL (\, SEQUENCE)))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (PREVIOUS (CL:NTHCDR (\, START) HANDLE))) (CDR HANDLE) (CL:IF (NOT (\, TEST-FORM)) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR (\, SEQUENCE) (\, START)))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((NOT (\, TEST-FORM)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT))))
+
+(CL:DEFUN SIMPLE-DELETE (ITEM SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (EQL ITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-DELETE-IF (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-DELETE-IF-NOT (TEST SEQUENCE START END) (SIMPLE-DELETE-MACRO SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-DELETE-MACRO (SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((HANDLE (CONS NIL (\, SEQUENCE)))) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (CL:DO ((PREVIOUS (CL:NTHCDR (\, START) HANDLE)) (%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) (INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (CDR HANDLE)) (SETQ CURRENT (CAR %%SUBSEQ)) (COND ((NOT (\, TEST-FORM)) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) (LAST (CL:NTHCDR (\, END) (\, SEQUENCE))) PREVIOUS CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (CDR HANDLE)) (SETQ PREVIOUS (CL:NTHCDR INDEX HANDLE)) (SETQ CURRENT (CADR PREVIOUS)) (COND ((NOT (\, TEST-FORM)) (SETQ LAST (CDR PREVIOUS))) (T (RPLACD PREVIOUS LAST) (CL:INCF NUMBER-OF-MATCHES)))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR (\, SEQUENCE) (\, START)))) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (\, START))) NIL (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT (SLOW-INDEX (CL:1- (\, END)))) (AND (> NUMBER-OF-MATCHES 0) (COPY-VECTOR-SUBSEQ RESULT (+ (\, START) NUMBER-OF-MATCHES) (\, END) RESULT (\, START) (- (\, END) NUMBER-OF-MATCHES))) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:DECF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (- (\, END) NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))))
+
+(CL:DEFUN COMPLEX-DELETE (ITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST ITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-DELETE-IF (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-DELETE-IF-NOT (TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-DELETE-MACRO SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:DELETE (ITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-DELETE ITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE ITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:DELETE-IF (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:DELETE-IF-NOT (TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-DELETE-IF-NOT TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-DELETE-IF-NOT TEST SEQUENCE START END))))
+
+(CL:DEFUN SIMPLE-REMOVE-DUPLICATES (SEQUENCE START END) (SIMPLE-REMOVE-MACRO SEQUENCE START END (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END)))
+
+(CL:DEFUN COMPLEX-REMOVE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE (LET ((RESULT-HEAD (CL:SUBSEQ SEQUENCE 0 START)) (RESULT-TAIL (CL:NTHCDR END SEQUENCE)) (RESULT-MIDDLE (CL:IF (NULL FROM-END) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT NEW-LIST TAIL) NEW-LIST (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (COLLECT-ITEM CURRENT NEW-LIST TAIL)))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH SEQUENCE)) (RESULT (CL:MAKE-ARRAY LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE SEQUENCE) :FILL-POINTER T)) (NUMBER-OF-MATCHES 0)) (COPY-VECTOR-SUBSEQ SEQUENCE 0 START RESULT 0) (CL:IF (NULL FROM-END) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN CL:REMOVE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) "The elements of Sequence are examined, and if any two match, one is discarded.  The resulting sequence is returned." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-REMOVE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-REMOVE-DUPLICATES SEQUENCE START END))))
+
+(CL:DEFUN SIMPLE-DELETE-DUPLICATES (SEQUENCE START END) (SEQ-DISPATCH SEQUENCE (LET ((HANDLE (CONS NIL SEQUENCE))) (FORWARD-LIST-LOOP SEQUENCE START END (INDEX CURRENT (PREVIOUS (CL:NTHCDR START HANDLE))) (CDR HANDLE) (CL:IF (NOT (SIMPLE-POSITION CURRENT (CDR %%SUBSEQ) 0 (- END INDEX 1))) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ))))) (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (SLOW-INDEX START)) NIL (COND ((NOT (SIMPLE-POSITION CURRENT SEQUENCE (CL:1+ INDEX) END)) (CL:SETF (CL:AREF RESULT SLOW-INDEX) CURRENT) (CL:INCF SLOW-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN COMPLEX-DELETE-DUPLICATES (SEQUENCE START END FROM-END KEY TEST TEST-NOT-P) (SEQ-DISPATCH SEQUENCE (LET ((HANDLE (CONS NIL SEQUENCE))) (CL:IF (NULL FROM-END) (CL:DO ((PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (CL:IF (NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) (CDR %%SUBSEQ) 0 (- END INDEX 1) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS)) (RPLACD PREVIOUS (CDR %%SUBSEQ)))) (CL:DO ((NUMBER-OF-MATCHES 0) (PREVIOUS (CL:NTHCDR START HANDLE)) (%%SUBSEQ (CL:NTHCDR START SEQUENCE) (CDR %%SUBSEQ)) (INDEX START (CL:1+ INDEX))) ((EQL INDEX END) (CDR HANDLE)) (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY (CAR %%SUBSEQ)) SEQUENCE START (- INDEX NUMBER-OF-MATCHES) NIL KEY TEST TEST-NOT-P)) (SETQ PREVIOUS (CDR PREVIOUS))) (T (RPLACD PREVIOUS (CDR %%SUBSEQ)) (CL:INCF NUMBER-OF-MATCHES)))))) (LET ((LENGTH (VECTOR-LENGTH SEQUENCE)) (NUMBER-OF-MATCHES 0) (RESULT (%%DESTRUCTIVE-RESULT-VECTOR SEQUENCE START))) (CL:IF (NULL FROM-END) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE (CL:1+ INDEX) END NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES)))) (FORWARD-VECTOR-LOOP SEQUENCE START END (INDEX CURRENT (RESULT-INDEX START) TEST-RESULT) NIL (COND ((NOT (COMPLEX-POSITION (CL:FUNCALL KEY CURRENT) SEQUENCE START INDEX NIL KEY TEST TEST-NOT-P)) (CL:SETF (CL:AREF RESULT RESULT-INDEX) CURRENT) (CL:INCF RESULT-INDEX)) (T (CL:INCF NUMBER-OF-MATCHES))))) (COPY-VECTOR-SUBSEQ SEQUENCE END LENGTH RESULT (- END NUMBER-OF-MATCHES)) (CL:SETF (CL:FILL-POINTER RESULT) (- LENGTH NUMBER-OF-MATCHES)) RESULT)))
+
+(CL:DEFUN CL:DELETE-DUPLICATES (SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P TEST-P TEST-NOT-P) (COMPLEX-DELETE-DUPLICATES SEQUENCE START END FROM-END KEY (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-DELETE-DUPLICATES SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (CL:IF (\, TEST-FORM) (\, NEWITEM) CURRENT)) (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL)))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (CL:IF (\, TEST-FORM) (\, NEWITEM) CURRENT))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (\, END)) RESULT))))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-SUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (LET ((RESULT-HEAD (CL:SUBSEQ (\, SEQUENCE) 0 (\, START))) (RESULT-TAIL (CL:NTHCDR (\, END) (\, SEQUENCE))) (RESULT-MIDDLE (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))) (COLLECT-ITEM NEW-ELEMENT NEW-LIST TAIL)) (BACKWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST NEW-ELEMENT) NEW-LIST (SETQ NEW-ELEMENT (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))) (CL:PUSH NEW-ELEMENT NEW-LIST))))) (NCONC RESULT-HEAD RESULT-MIDDLE RESULT-TAIL)) (LET* ((LENGTH (VECTOR-LENGTH (\, SEQUENCE))) (RESULT (MAKE-VECTOR LENGTH :ELEMENT-TYPE (CL:ARRAY-ELEMENT-TYPE (\, SEQUENCE))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) 0 (\, START) RESULT 0) (CL:IF (NULL (\, FROM-END)) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM))))) (BACKWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) NIL (CL:SETF (CL:AREF RESULT INDEX) (COND ((OR (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT))) (NOT (\, TEST-FORM))) CURRENT) (T (CL:INCF NUMBER-OF-MATCHES) (\, NEWITEM)))))) (COPY-VECTOR-SUBSEQ (\, SEQUENCE) (\, END) LENGTH RESULT (\, END)) RESULT)))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-SUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:SUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-SUBSTITUTE NEWITEM OLDITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:SUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:SUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-SUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END))))
+
+(DEFMACRO SIMPLE-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END TEST-FORM) (BQUOTE (SEQ-DISPATCH (\, SEQUENCE) (FORWARD-LIST-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT NEW-LIST TAIL NEW-ELEMENT) (\, SEQUENCE) (CL:IF (\, TEST-FORM) (RPLACA %%SUBSEQ (\, NEWITEM)))) (FORWARD-VECTOR-LOOP (\, SEQUENCE) (\, START) (\, END) (INDEX CURRENT) (\, SEQUENCE) (CL:IF (\, TEST-FORM) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM)))))))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (EQL OLDITEM CURRENT)))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (CL:FUNCALL TEST CURRENT)))
+
+(CL:DEFUN SIMPLE-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END) (SIMPLE-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END (NOT (CL:FUNCALL TEST CURRENT))))
+
+(DEFMACRO COMPLEX-NSUBSTITUTE-MACRO (NEWITEM SEQUENCE START END FROM-END KEY COUNT TEST-FORM) (BQUOTE (LET ((NUMBER-OF-MATCHES 0)) (SEQ-DISPATCH (\, SEQUENCE) (CL:IF (NULL (AND (\, FROM-END) (\, COUNT))) (CL:DO ((%%SUBSEQ (CL:NTHCDR (\, START) (\, SEQUENCE)) (CDR %%SUBSEQ)) (INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ (\, NEWITEM)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) %%SUBSEQ CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ %%SUBSEQ (CL:NTHCDR INDEX (\, SEQUENCE))) (SETQ CURRENT (CAR %%SUBSEQ)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (RPLACA %%SUBSEQ (\, NEWITEM))))) (LET ((LENGTH (VECTOR-LENGTH (\, SEQUENCE)))) (CL:IF (NULL (\, FROM-END)) (CL:DO ((INDEX (\, START) (CL:1+ INDEX)) CURRENT) ((OR (EQL INDEX (\, END)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CL:AREF (\, SEQUENCE) INDEX)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM)))) (CL:DO ((INDEX (CL:1- (\, END)) (CL:1- INDEX)) CURRENT) ((OR (< INDEX (\, START)) (AND (\, COUNT) (>= NUMBER-OF-MATCHES (\, COUNT)))) (\, SEQUENCE)) (SETQ CURRENT (CL:AREF (\, SEQUENCE) INDEX)) (CL:IF (AND (\, TEST-FORM) (CL:INCF NUMBER-OF-MATCHES)) (CL:SETF (CL:AREF (\, SEQUENCE) INDEX) (\, NEWITEM))))))))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT TEST TEST-NOT-P) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P (NOT (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT))) (CL:FUNCALL TEST OLDITEM (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT))))
+
+(CL:DEFUN COMPLEX-NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (COMPLEX-NSUBSTITUTE-MACRO NEWITEM SEQUENCE START END FROM-END KEY COUNT (NOT (CL:FUNCALL TEST (CL:FUNCALL KEY CURRENT)))))
+
+(CL:DEFUN CL:NSUBSTITUTE (NEWITEM OLDITEM SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P) (TEST (QUOTE EQL) TEST-P) (TEST-NOT NIL TEST-NOT-P)) (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (AND TEST-P TEST-NOT-P) (CL:ERROR "Both test and test-not provided")) (CL:IF (OR FROM-END-P KEY-P COUNT TEST-P TEST-NOT-P) (COMPLEX-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END FROM-END KEY COUNT (CL:IF TEST-NOT-P TEST-NOT TEST) TEST-NOT-P) (SIMPLE-NSUBSTITUTE NEWITEM OLDITEM SEQUENCE START END))))
+
+(CL:DEFUN CL:NSUBSTITUTE-IF (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:NSUBSTITUTE-IF-NOT (NEWITEM TEST SEQUENCE &KEY (START 0) END (FROM-END NIL FROM-END-P) COUNT (KEY (QUOTE CL:IDENTITY) KEY-P)) "Returns a sequence of the same kind as Sequence with the same elements except that all elements that match Old are replaced with New." (LET ((LENGTH (CL:LENGTH SEQUENCE))) (CL:IF (NULL END) (SETQ END LENGTH)) (CHECK-SUBSEQ SEQUENCE START END LENGTH) (CL:IF (OR FROM-END-P KEY-P COUNT) (COMPLEX-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END FROM-END KEY COUNT) (SIMPLE-NSUBSTITUTE-IF-NOT NEWITEM TEST SEQUENCE START END))))
+
+(CL:DEFUN CL:MAP-INTO (CL::RESULT-SEQUENCE CL:FUNCTION &REST CL::SEQUENCES) (* ;; "This is going to need work analogous to MAP; tomorrow...") (CL:IF (CDR CL::SEQUENCES) (CL::MAP-INTO-MULTIPLE CL::RESULT-SEQUENCE CL:FUNCTION CL::SEQUENCES) (CL::MAP-INTO-SINGLE CL::RESULT-SEQUENCE CL:FUNCTION (CAR CL::SEQUENCES))))
+
+(CL:DEFUN CL::MAP-INTO-SINGLE (CL::RESULT-SEQUENCE CL:FUNCTION SEQUENCE) (* ;; "Code borrowed from %%MAP-FOR-RESULT-SINGLE; needed changes to handle possible fill-pointer adjustment of RESULT-SEQUENCE") (LET (LENGTH) (SEQ-DISPATCH CL::RESULT-SEQUENCE (PROGN (CL:SETQ LENGTH (MIN (CL:LENGTH CL::RESULT-SEQUENCE) (CL:LENGTH SEQUENCE))) (SEQ-DISPATCH SEQUENCE (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT))) ((OR (NULL SUBSEQ) (NULL SUBRESULT))) (RPLACA SUBRESULT (CL:FUNCALL CL:FUNCTION (CAR SUBSEQ)))) (CL:DO ((INDEX 0 (CL:1+ INDEX)) (SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT))) ((EQL INDEX LENGTH)) (RPLACA SUBRESULT (CL:FUNCALL CL:FUNCTION (CL:AREF SEQUENCE INDEX)))))) (PROGN (* ;; "The actual length we want to do is (min (length sequence) (array-total-size result-sequence)), because RESULT-SEQUENCE might have a fill-pointer; if it does, we'll adjust it here.") (CL:SETQ LENGTH (MIN (CL:ARRAY-TOTAL-SIZE CL::RESULT-SEQUENCE) (CL:LENGTH SEQUENCE))) (CL:WHEN (CL:ARRAY-HAS-FILL-POINTER-P CL::RESULT-SEQUENCE) (CL:SETF (CL:FILL-POINTER CL::RESULT-SEQUENCE) LENGTH)) (SEQ-DISPATCH SEQUENCE (CL:DO ((SUBSEQ SEQUENCE (CDR SUBSEQ)) (INDEX 0 (CL:1+ INDEX))) ((OR (NULL SUBSEQ) (EQL INDEX LENGTH))) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:FUNCALL CL:FUNCTION (CAR SUBSEQ)))) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX LENGTH)) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:FUNCALL CL:FUNCTION (CL:AREF SEQUENCE INDEX))))))) CL::RESULT-SEQUENCE))
+
+(CL:DEFUN CL::MAP-INTO-MULTIPLE (CL::RESULT-SEQUENCE CL:FUNCTION CL::SEQUENCES) (* ;; "Code taken from %%MAP-FOR-RESULT-MULTIPLE and munged to handle case of fill-pointer in RESULT-SEQUENCE") (LET* ((MIN-LENGTH (%%MIN-SEQUENCE-LENGTH CL::SEQUENCES)) (ELT-SLICE (CL:MAKE-LIST (CL:LENGTH CL::SEQUENCES)))) (SEQ-DISPATCH CL::RESULT-SEQUENCE (PROGN (CL:SETQ MIN-LENGTH (MIN MIN-LENGTH (CL:LENGTH CL::RESULT-SEQUENCE))) (CL:DO ((SUBRESULT CL::RESULT-SEQUENCE (CDR SUBRESULT)) (INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) CL::RESULT-SEQUENCE) (RPLACA SUBRESULT (CL:APPLY CL:FUNCTION (%%FILL-SLICE INDEX ELT-SLICE CL::SEQUENCES))))) (PROGN (CL:SETQ MIN-LENGTH (MIN MIN-LENGTH (CL:ARRAY-TOTAL-SIZE CL::RESULT-SEQUENCE))) (CL:IF (CL:ARRAY-HAS-FILL-POINTER-P CL::RESULT-SEQUENCE) (CL:SETF (CL:FILL-POINTER CL::RESULT-SEQUENCE) MIN-LENGTH)) (CL:DO ((INDEX 0 (CL:1+ INDEX))) ((EQL INDEX MIN-LENGTH) CL::RESULT-SEQUENCE) (CL:SETF (CL:AREF CL::RESULT-SEQUENCE INDEX) (CL:APPLY CL:FUNCTION (%%FILL-SLICE INDEX ELT-SLICE CL::SEQUENCES))))))))
+
+(PUTPROPS CMLSEQMODIFY FILETYPE CL:COMPILE-FILE)
+(DECLARE%: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSEQMODIFY COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLSETF

@@ -0,0 +1,227 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+
(IL:FILECREATED "14-Feb-92 13:26:45" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSETF.;4|
 35330  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CMLSETFCOMS) (IL:FUNCTIONS ROTATEF CL::ROTATEF-INTERNAL CL::MV-LET* SETF GET-SETF-METHOD-MULTIPLE-VALUE PSETF SHIFTF CL::SHIFTF-INTERNAL)
+
+      IL:|previous| IL:|date:| " 4-Jan-92 15:22:54" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLSETF.;2|
+)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1992 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLSETFCOMS)
+
+(IL:RPAQQ IL:CMLSETFCOMS ((IL:FUNCTIONS GET-SETF-METHOD GET-SIMPLE-SETF-METHOD GET-SETF-METHOD-MULTIPLE-VALUE CL::DEFUN-SETF-METHOD) (IL:DEFINE-TYPES IL:SETFS) (IL:FUNCTIONS DEFSETF DEFINE-MODIFY-MACRO DEFINE-SETF-METHOD) (IL:COMS (IL:* IL:|;;| "Support for defstruct and friends ") (IL:FUNCTIONS DEFINE-SHARED-SETF-MACRO DEFINE-SHARED-SETF GET-SHARED-SETF-METHOD)) (IL:FUNCTIONS SETF SETF-ERROR) (IL:FUNCTIONS PSETF SHIFTF ROTATEF POP REMF) (IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier") (IL:FUNCTIONS CL::SHIFTF-INTERNAL CL::ROTATEF-INTERNAL) (IL:* IL:|;;| "A little support macro to make ROTATEF prettier") (IL:FUNCTIONS CL::MV-LET*) (IL:FUNCTIONS INCF DECF) (IL:FUNCTIONS MAYBE-MAKE-BINDING-FORM COUNT-OCCURRENCES CL::SETF-NAME-P XCL::DEFUN-SETF-NAME XCL::SET-DEFUN-SETF) (IL:FUNCTIONS PUSH PUSHNEW) (IL:SETFS CAR CDR CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR CDDDR CDDR FIRST SECOND THIRD FOURTH FIFTH SIXTH SEVENTH EIGHTH NINTH TENTH REST NTHCDR NTH GETF APPLY LDB MASK-FIELD CHAR-BIT THE CL:FDEFINITION) (IL:COMS (IL:* IL:\; "Some IL setfs, for no especially good reason") (IL:SETFS IL:GETHASH) (IL:FUNCTIONS IL:%SET-IL-GETHASH)) (IL:PROP IL:PROPTYPE :SETF-METHOD-EXPANDER :SETF-INVERSE :SHARED-SETF-INVERSE) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLSETF) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS (IL:ADDVARS (IL:NLAMA) (IL:NLAML) (IL:LAMA)))))
+
+(DEFUN GET-SETF-METHOD (FORM &OPTIONAL ENVIRONMENT) (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Do check number of the Store Variables") (MULTIPLE-VALUE-BIND (TEMPS VALUES STORES SETTER GETTER) (FUNCALL TEMP FORM ENVIRONMENT) (WHEN (/= (LENGTH STORES) 1) (WARN "SETF method contains more than one store variable. Only top of the elements was accepted.") (SETQ STORES (LIST (CAR STORES)))) (VALUES TEMPS VALUES STORES SETTER GETTER))) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))))
+
+(DEFUN GET-SIMPLE-SETF-METHOD (FORM SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SETF-INVERSE) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SETF-INVERSE-FORM GET-FORM)))
+
+(DEFUN GET-SETF-METHOD-MULTIPLE-VALUE (FORM &OPTIONAL ENVIRONMENT) (IL:* IL:\; "Edited  6-Feb-92 15:31 by jrb:") (LET (TEMP) (COND ((SYMBOLP FORM) (IL:* IL:|;;| "Symbols have a simple, constant SETF method.") (VALUES NIL NIL (LIST (SETQ TEMP (IL:GENSYM))) (IL:BQUOTE (SETQ (IL:\\\, FORM) (IL:\\\, TEMP))) FORM)) ((NOT (CONSP FORM)) (IL:* IL:\; "Syntax error") (SETF-ERROR FORM)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM) ENVIRONMENT)) (IL:* IL:|;;| "Lexical macros cannot have SETF methods defined upon them, so just expand this and try again.") (GET-SETF-METHOD (FUNCALL TEMP FORM ENVIRONMENT) ENVIRONMENT)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETF-INVERSE)) (GET (CAR FORM) (QUOTE IL:SETFN)))) (GET-SIMPLE-SETF-METHOD FORM TEMP)) ((SETQ TEMP (GET (CAR FORM) (QUOTE :SHARED-SETF-INVERSE))) (GET-SHARED-SETF-METHOD FORM TEMP)) ((SETQ TEMP (OR (GET (CAR FORM) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR FORM) (QUOTE IL:SETF-METHOD-EXPANDER)))) (IL:* IL:|;;| "Does not check the number of Store Variables.") (FUNCALL TEMP FORM ENVIRONMENT)) (T (MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 FORM ENVIRONMENT) (IF (AND DONE (NOT (EQ EXPANSION FORM))) (GET-SETF-METHOD EXPANSION ENVIRONMENT) (CL::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))))
+
+(DEFUN CL::DEFUN-SETF-METHOD (CL::FORM CL::ENVIRONMENT) (IL:* IL:|;;| "This doesn't need to do anything special with the ENVIRONMENT; all special search necessary is done by #'(SETF ,(CAR FORM))") (LET* ((CL::NEWVAL (GENSYM)) (CL::LET-LIST (MAPCAR (FUNCTION (LAMBDA (CL::X) (LIST (GENSYM) CL::X))) (CDR CL::FORM))) (CL::TEMPS (MAPCAR (FUNCTION CAR) CL::LET-LIST))) (VALUES CL::TEMPS (CDR CL::FORM) (LIST CL::NEWVAL) (IL:BQUOTE (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR CL::FORM)))) (IL:\\\, CL::NEWVAL) (IL:\\\,@ CL::TEMPS))) (CONS (CAR CL::FORM) CL::TEMPS))))
+
+(XCL:DEF-DEFINE-TYPE IL:SETFS "Common Lisp SETF definitions")
+
+(XCL:DEFDEFINER (DEFSETF (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFSETF (IL:\\\, NAME) "Inverse function")))))) IL:SETFS (NAME &REST REST &ENVIRONMENT ENV) (IL:* IL:|;;;| "Associates a SETF update function or macro with the specified access function or macro") (COND ((NULL REST) (ERROR "No body for DEFSETF of ~A" NAME)) ((AND (LISTP (CAR REST)) (CDR REST) (LISTP (CADR REST))) (IL:* IL:|;;| "The complex form:") (IL:* IL:|;;| "(defsetf access-fn args (store-var) {decl | doc}* {form}*)") (XCL:DESTRUCTURING-BIND (ARG-LIST (STORE-VAR &REST OTHERS) &BODY BODY) REST (IF OTHERS (CERROR "Ignore the extra items in the list." "Currently only one new-value variable is allowed in DEFSETF.")) (LET ((WHOLE-VAR (XCL:PACK (LIST NAME "-setf-form") (SYMBOL-PACKAGE NAME))) (ENVIRONMENT (XCL:PACK (LIST NAME "-setf-env") (SYMBOL-PACKAGE NAME))) (EXPANDER (XCL:PACK (LIST NAME "-setf-expander") (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (IL:PARSE-DEFMACRO ARG-LIST WHOLE-VAR BODY NAME ENV :ENVIRONMENT ENVIRONMENT) (IL:BQUOTE (PROGN (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER))) (FUNCTION (LAMBDA (ACCESS-FORM (IL:\\\, ENVIRONMENT)) (LET* ((DUMMIES (MAPCAR (FUNCTION (LAMBDA (X) (IL:GENSYM))) (CDR ACCESS-FORM))) ((IL:\\\, WHOLE-VAR) (CONS (CAR ACCESS-FORM) DUMMIES)) ((IL:\\\, STORE-VAR) (IL:GENSYM))) (VALUES DUMMIES (CDR ACCESS-FORM) (LIST (IL:\\\, STORE-VAR)) (BLOCK (IL:\\\, NAME) (IL:\\\, CODE)) (IL:\\\, WHOLE-VAR)))))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))))) ((SYMBOLP (CAR REST)) (IL:* IL:|;;| "The short form:") (IL:* IL:|;;| "(defsetf access-fn update-fn [doc])") (LET ((UPDATE-FN (CAR REST)) (DOC (CADR REST))) (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, UPDATE-FN)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))) (T (ERROR "Ill-formed DEFSETF for ~S." NAME))))
+
+(XCL:DEFDEFINER (DEFINE-MODIFY-MACRO (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-MODIFY-MACRO (IL:\\\, NAME) (IL:\\\,@ (XCL::%MAKE-FUNCTION-PROTOTYPE)))))))) IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL DOC-STRING) "Creates a new read-modify-write macro like PUSH or INCF." (LET ((OTHER-ARGS NIL) (REST-ARG NIL)) (DO ((LL LAMBDA-LIST (CDR LL)) (ARG NIL)) ((NULL LL)) (SETQ ARG (CAR LL)) (COND ((EQ ARG (QUOTE &OPTIONAL))) ((EQ ARG (QUOTE &REST)) (SETQ REST-ARG (CADR LL)) (RETURN NIL)) ((SYMBOLP ARG) (PUSH ARG OTHER-ARGS)) (T (PUSH (CAR ARG) OTHER-ARGS)))) (SETQ OTHER-ARGS (NREVERSE OTHER-ARGS)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (SI::%$$MODIFY-MACRO-FORM (IL:\\\,@ LAMBDA-LIST) &ENVIRONMENT SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:\\\, DOC-STRING) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, (IL:\\\, (IF REST-ARG (IL:BQUOTE (LIST* (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS) (IL:\\\, REST-ARG))) (IL:BQUOTE (LIST (QUOTE (IL:\\\, FUNCTION)) GETTER (IL:\\\,@ OTHER-ARGS)))))))) (IL:\\\, SETTER))))))))
+
+(XCL:DEFDEFINER (DEFINE-SETF-METHOD (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFINE-SETF-METHOD (IL:\\\, NAME) ("Arg list") "Body")))))) IL:SETFS (NAME LAMBDA-LIST &ENVIRONMENT ENV &BODY BODY) (LET ((WHOLE (XCL:PACK (LIST "whole-" NAME) (SYMBOL-PACKAGE NAME))) (ENVIRONMENT (XCL:PACK (LIST "env-" NAME) (SYMBOL-PACKAGE NAME))) (EXPANDER (XCL:PACK (LIST "setf-expander-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (NEWBODY LOCAL-DECS DOC) (IL:PARSE-DEFMACRO LAMBDA-LIST WHOLE BODY NAME ENV :ENVIRONMENT ENVIRONMENT :ERROR-STRING "Setf expander for ~S cannot be called with ~S args.") (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (DEFUN (IL:\\\, EXPANDER) ((IL:\\\, WHOLE) (IL:\\\, ENVIRONMENT)) (IL:\\\,@ LOCAL-DECS) (BLOCK (IL:\\\, NAME) (IL:\\\, NEWBODY))) (SET-SETF-METHOD-EXPANDER (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, EXPANDER))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))))
+
+
+
+(IL:* IL:|;;| "Support for defstruct and friends ")

+
+
+(XCL:DEFDEFINER DEFINE-SHARED-SETF-MACRO IL:FUNCTIONS (NAME ACCESSOR ARG-LIST STORE-VAR &BODY BODY &ENVIRONMENT ENV) (IL:* IL:|;;;| "Defines a shared SETF update function for a family of accessores -- used by defstruct") (IF (NOT (AND (CONSP STORE-VAR) (EQ 1 (LENGTH STORE-VAR)))) (ERROR "Store-var should be a list of one element: ~s" STORE-VAR)) (MULTIPLE-VALUE-BIND (CODE DECLS DOC) (XCL:PARSE-BODY BODY ENV T) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\, ACCESSOR) (IL:\\\,@ ARG-LIST) (IL:\\\,@ STORE-VAR)) (IL:\\\,@ DOC) (IL:\\\,@ DECLS) (IL:\\\,@ CODE)))))
+
+(XCL:DEFDEFINER DEFINE-SHARED-SETF IL:SETFS (NAME SHARED-EXPANDER &OPTIONAL DOC) (IL:* IL:|;;;| "Associates a shared SETF update macro with the specified accessor function -- used by defstruct") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD COMPILE EVAL) (SET-SHARED-SETF-INVERSE (QUOTE (IL:\\\, NAME)) (QUOTE (IL:\\\, SHARED-EXPANDER)))) (IL:\\\,@ (AND DOC (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE SETF)) (IL:\\\, DOC)))))))))
+
+(DEFUN GET-SHARED-SETF-METHOD (FORM SHARED-SETF-INVERSE) (IL:* IL:|;;| "Produce SETF method for a form that has a shared-setf-inverse.  Five values to return are: temp vars, values to bind them to, store temp var, store form, access form; the latter two are expressions that can use any of them temp vars.") (LET ((NEW-VAR (IL:GENSYM)) VARS VALS ARGS SHARED-SETF-INVERSE-FORM GET-FORM) (SETQ ARGS (MAPCAR (FUNCTION (LAMBDA (ARG) (COND ((IF (CONSP ARG) (EQ (CAR ARG) (QUOTE QUOTE)) (CONSTANTP ARG)) (IL:* IL:|;;| "We don't need gensym for this constant argument.  The test is a little more conservative than CL:CONSTANTP because it's not obvious that it's ok to evaluate a \"constant expression\" multiple times and get the same EQ object every time.") ARG) (T (IL:* IL:|;;| "Anything else might be side-effected, so will need to bind") (PUSH ARG VALS) (LET ((G (IL:GENSYM))) (PUSH G VARS) G))))) (CDR FORM))) (SETQ SHARED-SETF-INVERSE-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, SHARED-SETF-INVERSE) (IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS) (IL:\\\, NEW-VAR))))) (SETQ GET-FORM (MACROEXPAND-1 (IL:BQUOTE ((IL:\\\, (CAR FORM)) (IL:\\\,@ ARGS))))) (IL:* IL:|;;| "ARGS is now the arguments to FORM with gensyms substituted for the non-constant expressions") (VALUES (SETQ VARS (NREVERSE VARS)) (SETQ VALS (NREVERSE VALS)) (LIST NEW-VAR) SHARED-SETF-INVERSE-FORM GET-FORM)))
+
+(DEFMACRO SETF (PLACE NEW-VALUE &REST OTHERS &ENVIRONMENT ENV) (IL:* IL:|;;;| "Takes pairs of arguments like SETQ. The first is a place and the second is the value that is supposed to go into that place. Returns the last value. The place argument may be any of the access forms for which SETF knows a corresponding setting form.") (IL:* IL:|;;;| "We short-circuit the normal SETF-method mechanism for two very common special cases, so as to produce much simpler and more efficient code.  The two cases are symbols and forms with simple inverses.") (COND (OTHERS (IL:BQUOTE (PROGN (SETF (IL:\\\, PLACE) (IL:\\\, NEW-VALUE)) (SETF (IL:\\\,@ OTHERS))))) (T (PROG (TEMP) LP (COND ((SYMBOLP PLACE) (RETURN (IL:BQUOTE (SETQ (IL:\\\, PLACE) (IL:\\\, NEW-VALUE))))) ((OR (NOT (CONSP PLACE)) (NOT (SYMBOLP (CAR PLACE)))) (SETF-ERROR PLACE)) ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR PLACE) ENV)) (IL:* IL:|;;| "Before looking for an inverse, we have to macroexpand until it isn't a reference to a lexical macro, since those can't have SETF methods.") (SETQ PLACE (FUNCALL TEMP PLACE ENV))) ((SETQ TEMP (OR (GET (CAR PLACE) (QUOTE :SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETF-INVERSE)) (GET (CAR PLACE) (QUOTE IL:SETFN)))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((SETQ TEMP (GET (CAR PLACE) (QUOTE :SHARED-SETF-INVERSE))) (RETURN (IL:BQUOTE ((IL:\\\, TEMP) (IL:\\\, (CAR PLACE)) (IL:\\\,@ (CDR PLACE)) (IL:\\\, NEW-VALUE))))) ((OR (GET (CAR PLACE) (QUOTE :SETF-METHOD-EXPANDER)) (GET (CAR PLACE) (QUOTE IL:SETF-METHOD-EXPANDER))) (IL:* IL:|;;| "General setf hair") (RETURN (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVALS SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE PLACE ENV) (IF (NULL (CDR NEWVALS)) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVALS)) (IL:\\\, NEW-VALUE))) (IL:\\\, SETTER))) (IL:* IL:|;;| "It's one of those multiple-value jobbers...") (IL:BQUOTE (LET* ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS))) (MULTIPLE-VALUE-BIND (IL:\\\, NEWVALS) (IL:\\\, NEW-VALUE) (IL:\\\, SETTER)))))))) ((MULTIPLE-VALUE-BIND (EXPANSION DONE) (MACROEXPAND-1 PLACE ENV) (IL:* IL:|;;| "Try macro expanding") (WHEN (AND DONE (NOT (EQ EXPANSION PLACE))) (SETQ PLACE EXPANSION)))) (T (IL:* IL:|;;| "Nothing worked; we have to assume there's a (defun (setf mumble)...) out there somewhere") (RETURN (LET ((NEW-VALUE-TEMP (GENSYM)) (LET-LIST (MAPCAR (FUNCTION (LAMBDA (X) (LIST (GENSYM) X))) (CDR PLACE)))) (IL:BQUOTE (LET ((IL:\\\,@ LET-LIST) ((IL:\\\, NEW-VALUE-TEMP) (IL:\\\, NEW-VALUE))) (FUNCALL (FUNCTION (SETF (IL:\\\, (CAR PLACE)))) (IL:\\\, NEW-VALUE-TEMP) (IL:\\\,@ (MAPCAR (FUNCTION CAR) LET-LIST))))))))) (GO LP)))))
+
+(DEFUN SETF-ERROR (FN &OPTIONAL FORM) (IL:* IL:|;;| "Common error routine for invalid SETF's.  FN is the thing we tried to find a setf method for, FORM is its parent (not supplied when the form is a non-list).") (ERROR "~S is not a known location specifier for SETF." FN))
+
+(DEFMACRO PSETF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "This is to SETF as PSETQ is to SETQ.  Args are alternating place expressions and values to go into those places.  All of the subforms and values are determined, left to right, and only then are the locations updated.  Returns NIL.\"") (DO ((A ARGS (CDDR A)) (LET-LIST NIL) (MV-SET-LIST NIL) (SETF-LIST NIL)) ((ATOM A) (IL:BQUOTE ((IL:\\\, (QUOTE LET)) (IL:\\\, (REVERSE LET-LIST)) (IL:\\\,@ (REVERSE MV-SET-LIST)) (IL:\\\,@ (REVERSE SETF-LIST)) NIL))) (IF (ATOM (CDR A)) (ERROR "Odd number of args to PSETF.")) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD-MULTIPLE-VALUE (CAR A) ENV) (DECLARE (IGNORE GETTER)) (DO* ((D DUMMIES (CDR D)) (V VALS (CDR V))) ((NULL D)) (PUSH (LIST (CAR D) (CAR V)) LET-LIST)) (IF (CDR NEWVAL) (PROGN (SETQ LET-LIST (APPEND NEWVAL LET-LIST)) (PUSH (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, NEWVAL) (IL:\\\, (CADR A)))) MV-SET-LIST)) (PUSH (LIST (CAR NEWVAL) (CADR A)) LET-LIST)) (PUSH SETTER SETF-LIST))))
+
+(DEFMACRO SHIFTF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right, returns old value of 1st") (IL:* IL:|;;| "CLtL2 is ambiguous on whether multiple-values from the first form should be returned or not.  Consistencty votes yes, expediency votes no; I choose consistency (screw the New Jersey design philosophy!).") (COND ((OR (NULL ARGS) (NULL (CDR ARGS))) (ERROR "SHIFTF needs at least two arguments")) (T (CL::SHIFTF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE)))))
+
+(DEFMACRO ROTATEF (&REST ARGS &ENVIRONMENT ENV) (IL:* IL:|;;| "Assigns to each place the value of the form to its right; last gets first. Returns NIL.") (IL:* IL:|;;| "forms evaluated in order") (COND ((NULL ARGS) NIL) ((NULL (CDR ARGS)) (IL:BQUOTE (PROGN (IL:\\\, (CAR ARGS)) NIL))) (T (CL::ROTATEF-INTERNAL ARGS ENV (QUOTE GET-SETF-METHOD-MULTIPLE-VALUE)))))
+
+(DEFMACRO POP (PLACE &ENVIRONMENT ENV) "Pops one item off the front of PLACE and returns it." (IF (SYMBOLP PLACE) (IL:BQUOTE (PROG1 (CAR (IL:\\\, PLACE)) (SETQ (IL:\\\, PLACE) (CDR (IL:\\\, PLACE))))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) (IL:\\\, (LIST (CAR NEWVAL) GETTER))) (PROG1 (CAR (IL:\\\, (CAR NEWVAL))) (SETQ (IL:\\\, (CAR NEWVAL)) (CDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER)))))))
+
+(DEFMACRO REMF (PLACE INDICATOR &ENVIRONMENT ENV) "Destructively remove INDICATOR from PLACE, returning T if it was present, NIL if not" (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((IND-TEMP (IL:GENSYM)) (LOCAL1 (IL:GENSYM)) (LOCAL2 (IL:GENSYM))) (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAL)) (IL:\\\, GETTER)) ((IL:\\\, IND-TEMP) (IL:\\\, INDICATOR))) (DO (((IL:\\\, LOCAL1) (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, LOCAL1))) ((IL:\\\, LOCAL2) NIL (IL:\\\, LOCAL1))) ((ATOM (IL:\\\, LOCAL1)) NIL) (COND ((ATOM (CDR (IL:\\\, LOCAL1))) (ERROR "Odd-length property list in REMF.")) ((EQ (CAR (IL:\\\, LOCAL1)) (IL:\\\, IND-TEMP)) (COND ((IL:\\\, LOCAL2) (RPLACD (CDR (IL:\\\, LOCAL2)) (CDDR (IL:\\\, LOCAL1))) (RETURN T)) (T (SETQ (IL:\\\, (CAR NEWVAL)) (CDDR (IL:\\\, (CAR NEWVAL)))) (IL:\\\, SETTER) (RETURN T)))))))))))
+
+
+
+(IL:* IL:|;;| "A little suppost stuff to make writing the undoable versions easier")

+
+
+(DEFUN CL::SHIFTF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 11-Feb-92 15:45 by jrb:") (LET (CL::LET-LIST CL::MV-SET-LIST CL::SETF-LIST CL::GETTER) (FLET ((CL::BIND-LETS (CL::DUMMIES CL::VALS) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST))) (CL::HANDLE-GETTER (CL::NEXT-VAR CL::GETTER) (SETQ CL::LET-LIST (APPEND CL::NEXT-VAR CL::LET-LIST)) (PUSH (IF (CDR CL::NEXT-VAR) (IL:BQUOTE (MULTIPLE-VALUE-SETQ (IL:\\\, CL::NEXT-VAR) (IL:\\\, CL::GETTER))) (IL:BQUOTE (SETQ (IL:\\\, (CAR CL::NEXT-VAR)) (IL:\\\, CL::GETTER)))) CL::MV-SET-LIST))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::FIRST-NEWVAL CL::SETTER CL::FIRST-GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::ARGS) CL::ENV) (CL::BIND-LETS CL::DUMMIES CL::VALS) (PUSH CL::SETTER CL::SETF-LIST) (DO* ((CL::A (CDR CL::ARGS) (CDR CL::A)) (CL::NEXT-VAR CL::FIRST-NEWVAL) (CL::DUMMIES) (CL::VALS) (CL::NEWVAL) (CL::SETTER)) ((ATOM (CDR CL::A)) (CL::HANDLE-GETTER CL::NEXT-VAR (CAR CL::A)) (IL:BQUOTE (LET* (IL:\\\, (REVERSE CL::LET-LIST)) (MULTIPLE-VALUE-PROG1 (IL:\\\, CL::FIRST-GETTER) (IL:\\\,@ (REVERSE CL::MV-SET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)))))) (MULTIPLE-VALUE-SETQ (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV)) (CL::BIND-LETS CL::DUMMIES CL::VALS) (CL::HANDLE-GETTER CL::NEXT-VAR CL::GETTER) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL))))))
+
+(DEFUN CL::ROTATEF-INTERNAL (CL::ARGS CL::ENV CL::SETF-METHOD-GETTER) (IL:* IL:\; "Edited 12-Feb-92 13:10 by jrb:") (DO ((CL::A CL::ARGS (CDR CL::A)) (CL::LET-LIST NIL) (CL::SETF-LIST NIL) (CL::NEXT-VAR NIL) (CL::FIX-ME NIL)) ((ATOM CL::A) (SETF (FIRST CL::FIX-ME) (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR))) (IL:BQUOTE (CL::MV-LET* (IL:\\\, (REVERSE CL::LET-LIST)) (IL:\\\,@ (REVERSE CL::SETF-LIST)) NIL))) (MULTIPLE-VALUE-BIND (CL::DUMMIES CL::VALS CL::NEWVAL CL::SETTER CL::GETTER) (FUNCALL CL::SETF-METHOD-GETTER (CAR CL::A) CL::ENV) (DO ((CL::D CL::DUMMIES (CDR CL::D)) (CL::V CL::VALS (CDR CL::V))) ((NULL CL::D)) (PUSH (LIST (CAR CL::D) (CAR CL::V)) CL::LET-LIST)) (PUSH (LIST (IF (CDR CL::NEXT-VAR) CL::NEXT-VAR (CAR CL::NEXT-VAR)) CL::GETTER) CL::LET-LIST) (UNLESS CL::FIX-ME (SETQ CL::FIX-ME (CAR CL::LET-LIST))) (PUSH CL::SETTER CL::SETF-LIST) (SETQ CL::NEXT-VAR CL::NEWVAL))))
+
+
+
+(IL:* IL:|;;| "A little support macro to make ROTATEF prettier")

+
+
+(DEFMACRO CL::MV-LET* (CL::BINDING-LIST &REST CL::FORMS) (IF (NULL CL::BINDING-LIST) (IL:BQUOTE (LAMBDA NIL (IL:\\\,@ CL::FORMS))) (LABELS ((CL::MUNCH-CLAUSE (CL::BINDING-LIST) (LET ((CL::CLAUSE (POP CL::BINDING-LIST))) (IF (CONSP (CAR CL::CLAUSE)) (IL:BQUOTE (MULTIPLE-VALUE-BIND (IL:\\\, (CAR CL::CLAUSE)) (IL:\\\, (CADR CL::CLAUSE)) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS)))) (IL:BQUOTE ((LAMBDA ((IL:\\\, (CAR CL::CLAUSE))) (IL:\\\,@ (IF CL::BINDING-LIST (LIST (CL::MUNCH-CLAUSE CL::BINDING-LIST)) CL::FORMS))) (IL:\\\, (CADR CL::CLAUSE)))))))) (CL::MUNCH-CLAUSE CL::BINDING-LIST))))
+
+(DEFINE-MODIFY-MACRO INCF (&OPTIONAL (DELTA 1)) + "The first argument is some location holding a number.  This number is
+  incremented by the second argument, DELTA, which defaults to 1.")
+
+(DEFINE-MODIFY-MACRO DECF (&OPTIONAL (DELTA 1)) - "The first argument is some location holding a number.  This number is
+  decremented by the second argument, DELTA, which defaults to 1.")
+
+(DEFUN MAYBE-MAKE-BINDING-FORM (NEWVAL-FORM DUMMIES VALS NEWVAR SETTER GETTER) (IL:* IL:|;;| "For use in SETF-like forms to produce their final expression without using the NEWVAR gensym where possible.  DUMMIES thru GETTER are the five values returned from the SETF method.  NEWVAL-FORM is an expression to which the (sole) NEWVAR is logically to be bound, written in terms of the GETTER form.  If it looks like there are no side-effect problems, we substitute NEWVAL-FORM into SETTER; otherwise we return a binding form that returns SETTER correctly.") (IF (OR DUMMIES (> (COUNT-OCCURRENCES (CAR NEWVAR) SETTER) 1)) (IL:* IL:\; " have to do messy binding form") (IL:BQUOTE ((IL:\\\, (QUOTE LET*)) ((IL:\\\,@ (MAPCAR (FUNCTION LIST) DUMMIES VALS)) ((IL:\\\, (CAR NEWVAR)) (IL:\\\, NEWVAL-FORM))) (IL:\\\, SETTER))) (IL:* IL:\; "No temp vars, setter used only once, so nothing can be side-effected, so store it directly") (SUBST NEWVAL-FORM (CAR NEWVAR) SETTER)))
+
+(DEFUN COUNT-OCCURRENCES (SYMBOL FORM) (COND ((CONSP FORM) (+ (COUNT-OCCURRENCES SYMBOL (CAR FORM)) (COUNT-OCCURRENCES SYMBOL (CDR FORM)))) ((EQ SYMBOL FORM) 1) (T 0)))
+
+(DEFMACRO CL::SETF-NAME-P (CL::THING) (IL:BQUOTE (AND (CONSP (IL:\\\, CL::THING)) (EQ (CAR (IL:\\\, CL::THING)) (QUOTE SETF)) (CONSP (CDR (IL:\\\, CL::THING))) (SYMBOLP (CADR (IL:\\\, CL::THING))))))
+
+(DEFUN XCL::DEFUN-SETF-NAME (XCL::REAL-NAME) (XCL:PACK (LIST XCL::REAL-NAME "-defun-setf") (SYMBOL-PACKAGE XCL::REAL-NAME)))
+
+(DEFUN XCL::SET-DEFUN-SETF (XCL::NAME XCL::DEFUN-SETF-FN) (REMPROP XCL::NAME (QUOTE IL:SETF-METHOD-EXPANDER)) (REMPROP XCL::NAME :SETF-METHOD-EXPANDER) (REMPROP XCL::NAME :SETF-INVERSE) (SETF (GET XCL::NAME :SETF-DEFUN) XCL::DEFUN-SETF-FN))
+
+(DEFMACRO PUSH (OBJ PLACE &ENVIRONMENT ENV) "Conses OBJ onto PLACE, returning the modified list." (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (CONS (IL:\\\, OBJ) (IL:\\\, PLACE)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (CONS (IL:\\\, OBJ) (IL:\\\, GETTER))) DUMMIES VALS NEWVAL SETTER GETTER))))
+
+(DEFMACRO PUSHNEW (OBJ PLACE &REST KEYS &ENVIRONMENT ENV) "Conses OBJ onto PLACE unless its already there, using :TEST if necessary" (IF (SYMBOLP PLACE) (IL:BQUOTE (SETQ (IL:\\\, PLACE) (ADJOIN (IL:\\\, OBJ) (IL:\\\, PLACE) (IL:\\\,@ KEYS)))) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (MAYBE-MAKE-BINDING-FORM (IL:BQUOTE (ADJOIN (IL:\\\, OBJ) (IL:\\\, GETTER) (IL:\\\,@ KEYS))) DUMMIES VALS NEWVAL SETTER GETTER))))
+
+(DEFSETF CAR (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF CDR (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF CAAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADAAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDAR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADDR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CADR (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDAAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDADR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDADR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDAR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDAR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF CDDR (X) (V) (IL:BQUOTE (CDR (RPLACD (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FIRST (X) (V) (IL:BQUOTE (CAR (RPLACA (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF SECOND (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF THIRD (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FOURTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF FIFTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (IL:\\\, X)) (IL:\\\, V)))))
+
+(DEFSETF SIXTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF SEVENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF EIGHTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF NINTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDDDDR (CDDDDR (IL:\\\, X))) (IL:\\\, V)))))
+
+(DEFSETF TENTH (X) (V) (IL:BQUOTE (CAR (RPLACA (CDR (CDDDDR (CDDDDR (IL:\\\, X)))) (IL:\\\, V)))))
+
+(DEFSETF REST (X) (V) (IL:BQUOTE (CDR (RPLACD (IL:\\\, X) (IL:\\\, V)))))
+
+(DEFSETF NTHCDR (N LIST) (NEWVAL) (IL:BQUOTE (CDR (RPLACD (NTHCDR (1- (IL:\\\, N)) (IL:\\\, LIST)) (IL:\\\, NEWVAL)))))
+
+(DEFSETF NTH %SET-NTH)
+
+(DEFINE-SETF-METHOD GETF (PLACE PROP &OPTIONAL DEFAULT &ENVIRONMENT ENV) (MULTIPLE-VALUE-BIND (TEMPS VALUES STORES SET GET) (GET-SETF-METHOD PLACE ENV) (LET ((NEWVAL (IL:GENSYM)) (PTEMP (IL:GENSYM)) (DEF-TEMP (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ TEMPS) (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP))))))) (IL:BQUOTE ((IL:\\\,@ VALUES) (IL:\\\, GET) (IL:\\\, PROP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEFAULT))))))) (IL:BQUOTE ((IL:\\\, NEWVAL))) (IL:BQUOTE (COND ((NULL (IL:\\\, (CAR STORES))) (LET* (IL:\\\, (LIST (APPEND STORES (IL:BQUOTE ((LIST (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))))) (IL:\\\, SET)) (IL:\\\, NEWVAL)) (T (IL:LISTPUT (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\, NEWVAL))))) (IL:BQUOTE (GETF (IL:\\\, (CAR STORES)) (IL:\\\, PTEMP) (IL:\\\,@ (IF DEFAULT (IL:BQUOTE ((IL:\\\, DEF-TEMP)))))))))))
+
+(DEFINE-SETF-METHOD APPLY (FN &REST ARGS &ENVIRONMENT ENV) (IF (AND (CONSP FN) (EQ (LENGTH FN) 2) (MEMBER (FIRST FN) (QUOTE (FUNCTION IL:FUNCTION QUOTE)) :TEST (FUNCTION EQ)) (SYMBOLP (SECOND FN))) (SETQ FN (SECOND FN)) (ERROR "Setf of Apply is only defined for function args of form #'symbol.")) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD (CONS FN ARGS) ENV) (IL:* IL:|;;| "Make sure the place is one that we can handle.") (UNLESS (AND (EQ (CAR (LAST ARGS)) (CAR (LAST VALS))) (EQ (CAR (LAST GETTER)) (CAR (LAST DUMMIES))) (EQ (CAR (LAST SETTER)) (CAR (LAST DUMMIES)))) (ERROR "Apply of ~S not understood as a location for Setf." FN)) (VALUES DUMMIES VALS NEWVAL (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR SETTER))) (IL:\\\,@ (CDR SETTER)))) (IL:BQUOTE (APPLY (FUNCTION (IL:\\\, (CAR GETTER))) (IL:\\\,@ (CDR GETTER)))))))
+
+(DEFINE-SETF-METHOD LDB (BYTESPEC PLACE &ENVIRONMENT ENV) "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this
+  place with bits from the low-order end of the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DPB (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (LDB (IL:\\\, BTEMP) (IL:\\\, GETTER)))))))
+
+(DEFINE-SETF-METHOD MASK-FIELD (BYTESPEC PLACE &ENVIRONMENT ENV) "The first argument is a byte specifier.  The second is any place form
+  acceptable to SETF.  Replaces the specified byte of the number in this place
+  with bits from the corresponding position in the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (CONS BTEMP DUMMIES) (CONS BYTESPEC VALS) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (DEPOSIT-FIELD (IL:\\\, GNUVAL) (IL:\\\, BTEMP) (IL:\\\, GETTER)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (MASK-FIELD (IL:\\\, BTEMP) (IL:\\\, GETTER)))))))
+
+(DEFINE-SETF-METHOD CHAR-BIT (PLACE BIT-NAME &ENVIRONMENT ENV) "The first argument is any place form acceptable to SETF.  Replaces the
+  specified bit of the character in this place with the new value." (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (LET ((BTEMP (IL:GENSYM)) (GNUVAL (IL:GENSYM))) (VALUES (IL:BQUOTE ((IL:\\\,@ DUMMIES) (IL:\\\, BTEMP))) (IL:BQUOTE ((IL:\\\,@ VALS) (IL:\\\, BIT-NAME))) (LIST GNUVAL) (IL:BQUOTE (LET (((IL:\\\, (CAR NEWVAL)) (SET-CHAR-BIT (IL:\\\, GETTER) (IL:\\\, BTEMP) (IL:\\\, GNUVAL)))) (IL:\\\, SETTER) (IL:\\\, GNUVAL))) (IL:BQUOTE (CHAR-BIT (IL:\\\, GETTER) (IL:\\\, BTEMP)))))))
+
+(DEFINE-SETF-METHOD THE (TYPE PLACE &ENVIRONMENT ENV) (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER) (GET-SETF-METHOD PLACE ENV) (VALUES DUMMIES VALS NEWVAL (SUBST (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, (CAR NEWVAL)))) (CAR NEWVAL) SETTER) (IL:BQUOTE (THE (IL:\\\, TYPE) (IL:\\\, GETTER))))))
+
+(DEFSETF CL:FDEFINITION CL::SET-FDEFINITION)
+
+
+
+(IL:* IL:\; "Some IL setfs, for no especially good reason")

+
+
+(DEFSETF IL:GETHASH IL:%SET-IL-GETHASH)
+
+(DEFMACRO IL:%SET-IL-GETHASH (KEY HASH-TABLE &OPTIONAL NEWVALUE) (IL:* IL:|;;| "SETF inverse for IL:GETHASH.  Tricky parts are that args to IL:PUTHASH are in wrong order, and IL:GETHASH might default its second arg (yuck, let's flush that), in which case the third arg is absent and the second is the new value.") (COND ((NOT NEWVALUE) (IL:* IL:\; "Defaulted hash table") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, HASH-TABLE)))) ((OR (IL:CONSTANTEXPRESSIONP NEWVALUE) (AND (SYMBOLP NEWVALUE) (SYMBOLP HASH-TABLE))) (IL:* IL:\; "Ok to swap args") (IL:BQUOTE (IL:PUTHASH (IL:\\\, KEY) (IL:\\\, NEWVALUE) (IL:\\\, HASH-TABLE)))) (T (IL:BQUOTE (LET (IL:$$GETHASH-TABLE) (DECLARE (IL:LOCALVARS IL:$$GETHASH-TABLE)) (IL:PUTHASH (IL:\\\, KEY) (PROGN (IL:SETQ IL:$$GETHASH-TABLE (IL:\\\, HASH-TABLE)) (IL:\\\, NEWVALUE)) IL:$$GETHASH-TABLE))))))
+
+(IL:PUTPROPS :SETF-METHOD-EXPANDER IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :SETF-INVERSE IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS :SHARED-SETF-INVERSE IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:CMLSETF IL:FILETYPE :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLSETF IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA)
+
+(IL:ADDTOVAR IL:NLAML)
+
+(IL:ADDTOVAR IL:LAMA)
+)
+(IL:PUTPROPS IL:CMLSETF IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1992))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLSMARTARGS

@@ -0,0 +1,752 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 15:15:10" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSMARTARGS.;2"
 36820  
+
+      previous date%: "13-Apr-92 16:26:44" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSMARTARGS.;1"
+)
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSMARTARGSCOMS)
+
+(RPAQQ CMLSMARTARGSCOMS

+       ((VARS *CL-ARGINFO-LIST* *XCL-ARGINFO-LIST*)
+        (FUNCTIONS ARGINFO-MUNG CLSMARTEN)
+        [DECLARE%: DONTEVAL@LOAD DOCOPY (P (CLSMARTEN *CL-ARGINFO-LIST*)
+                                           (CLSMARTEN *XCL-ARGINFO-LIST*)
+                                           (SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST*
+                                                                         'NOBIND]
+        (PROP FILETYPE CMLSMARTARGS)))
+
+(RPAQQ *CL-ARGINFO-LIST*

+       (((LISP:* +)
+         &REST NUMBERS)
+        ((- / LISP:/= < <= = > >= MAX MIN)
+         LISP:NUMBER &REST MORE-NUMBERS)
+        ((LISP:1+ LISP:1- ABS LISP:ACOS LISP:ACOSH LISP:ASIN LISP:ASINH LISP:ATANH LISP:CONJUGATE 
+                LISP:COSH LISP:EXP LISP:IMAGPART MINUSP LISP:PHASE LISP:PLUSP LISP:RATIONAL 
+                LISP:RATIONALIZE LISP:REALPART LISP:SIGNUM LISP:SINH LISP:SQRT LISP:TANH LISP:ZEROP)
+         LISP:NUMBER)
+        (LISP:ACONS KEY DATUM A-LIST)
+        ((LISP:ADJOIN LISP:MEMBER)
+         ITEM LIST &KEY :TEST :TEST-NOT :KEY)
+        (LISP:ADJUST-ARRAY LISP:ARRAY NEW-DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT 
+               :INITIAL-CONTENTS :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP 
+               :DISPLACED-TO-BASE)
+        ((LISP:ADJUSTABLE-ARRAY-P LISP:ARRAY-DIMENSIONS LISP:ARRAY-ELEMENT-TYPE 
+                LISP:ARRAY-HAS-FILL-POINTER-P LISP:ARRAY-RANK LISP:ARRAY-TOTAL-SIZE)
+         LISP:ARRAY)
+        ((LISP:ALPHA-CHAR-P LISP:ALPHANUMERICP LISP:BOTH-CASE-P LISP:CHAR-BITS LISP:CHAR-CODE 
+                LISP:CHAR-DOWNCASE LISP:CHAR-FONT LISP:CHAR-INT LISP:CHAR-NAME LISP:CHAR-UPCASE 
+                LISP:GRAPHIC-CHAR-P LISP:LOWER-CASE-P LISP:STANDARD-CHAR-P LISP:STRING-CHAR-P 
+                LISP:UPPER-CASE-P)
+         LISP:CHAR)
+        ((AND OR PROGN)
+         (CURLYLIST FORM)
+         #\*)
+        ((LISP:APPEND NCONC)
+         &REST LISTS)
+        (LISP:APPLY LISP:FUNCTION ARG &REST MORE-ARGS)
+        (LISP:APPLYHOOK LISP:FUNCTION ARGS EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV)
+        ((LISP:APROPOS LISP:APROPOS-LIST)
+         STRING &OPTIONAL PACKAGE)
+        ((LISP:AREF LISP:ARRAY-IN-BOUNDS-P LISP:ARRAY-ROW-MAJOR-INDEX)
+         LISP:ARRAY &REST SUBSCRIPTS)
+        (LISP:ARRAY-DIMENSION LISP:ARRAY AXIS-NUMBER)
+        ((LISP:ARRAYP LISP:ATOM LISP:BIT-VECTOR-P LISP:CHARACTER LISP:CHARACTERP LISP:COMMONP 
+                LISP:COMPILED-FUNCTION-P LISP:COMPLEXP LISP:CONSP LISP:CONSTANTP LISP:COPY-TREE 
+                LISP:DESCRIBE LISP:ENDP LISP:FLOATP LISP:FUNCTIONP LISP:HASH-TABLE-P LISP:IDENTITY 
+                INSPECT LISP:INTEGERP LISP:KEYWORDP LISP:LISTP NULL LISP:NUMBERP LISP:PACKAGEP 
+                LISP:PATHNAMEP LISP:PRIN1-TO-STRING LISP:PRINC-TO-STRING LISP:RANDOM-STATE-P 
+                LISP:RATIONALP READTABLEP LISP:SIMPLE-BIT-VECTOR-P LISP:SIMPLE-STRING-P 
+                LISP:SIMPLE-VECTOR-P STREAMP LISP:STRINGP LISP:SXHASH LISP:SYMBOLP LISP:TYPE-OF 
+                LISP:VECTORP)
+         OBJECT)
+        (LISP:ASH INTEGER LISP:COUNT)
+        [LISP:ASSERT TEST-FORM (SQUARELIST ((CURLYLIST* PLACE))
+                                      (SQUARELIST STRING (CURLYLIST* ARG]
+        ((LISP:ASSOC LISP:RASSOC)
+         ITEM A-LIST &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:ASSOC-IF LISP:ASSOC-IF-NOT LISP:RASSOC-IF LISP:RASSOC-IF-NOT)
+         PREDICATE A-LIST &KEY :KEY)
+        (LISP:ATAN Y &OPTIONAL X)
+        (BIT BIT-ARRAY &REST SUBSCRIPTS)
+        ((LISP:BIT-AND LISP:BIT-EQV LISP:BIT-IOR LISP:BIT-XOR)
+         BIT-ARRAY1 BIT-ARRAY-2 &OPTIONAL RESULT-BIT-ARRAY)
+        ((LISP:BIT-ANDC1 LISP:BIT-ANDC2 LISP:BIT-NAND LISP:BIT-NOR LISP:BIT-ORC1 LISP:BIT-ORC2)
+         BIT-ARRAY1 BIT-ARRAY2 &OPTIONAL RESULT-BIT-ARRAY)
+        (LISP:BIT-NOT BIT-ARRAY &OPTIONAL RESULT-BIT-ARRAY)
+        (LISP:BLOCK NAME
+            (CURLYLIST FORM)
+            #\*)
+        (LISP:BOOLE OP INTEGER1 INTEGER2)
+        ((BOUNDP LISP:FBOUNDP LISP:FMAKUNBOUND LISP:MAKE-SYNONYM-STREAM LISP:MAKUNBOUND 
+                LISP:SPECIAL-FORM-P LISP:SYMBOL-FUNCTION LISP:SYMBOL-PLIST LISP:SYMBOL-VALUE)
+         LISP:SYMBOL)
+        (LISP:BREAK &OPTIONAL FORMAT-STRING &REST ARGS)
+        ((LISP:BUTLAST LISP:NBUTLAST)
+         LIST &OPTIONAL N)
+        (BYTE SIZE LISP:POSITION)
+        ((LISP:BYTE-POSITION BYTE-SIZE)
+         BYTESPEC)
+        ((CAAAAR CAAADR CAAAR CAADAR CAADDR CAADR CAAR CADAAR CADADR CADAR CADDAR CADDDR CADDR CADR 
+                CAR CDAAAR CDAADR CDAAR CDADAR CDADDR CDADR CDAR CDDAAR CDDADR CDDAR CDDDAR CDDDDR 
+                CDDDR CDDR CDR LISP:EIGHTH LISP:FIFTH LISP:FIRST LISP:FOURTH LISP:LIST-LENGTH 
+                LISP:NINTH LISP:REST LISP:SECOND LISP:SEVENTH LISP:SIXTH LISP:TENTH LISP:THIRD)
+         LIST)
+        [(CASE LISP:ECASE)
+         KEYFORM
+         (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY))
+                             #\| KEY)
+                      (CURLYLIST* FORM]
+        (LISP:CATCH TAG
+            (CURLYLIST FORM)
+            #\*)
+        [LISP:CCASE KEYPLACE (CURLYLIST* ((CURLYLIST ((CURLYLIST* KEY))
+                                                 #\| KEY)
+                                          (CURLYLIST* FORM]
+        ((LISP:CEILING LISP:FCEILING LISP:FFLOOR LISP:FLOOR LISP:FROUND LISP:FTRUNCATE ROUND 
+                LISP:TRUNCATE)
+         LISP:NUMBER &OPTIONAL DIVISOR)
+        (LISP:CERROR CONTINUE-FORMAT-STRING ERROR-FORMAT-STRING &REST ARGS)
+        (LISP:CHAR STRING INDEX)
+        (LISP:CHAR-BIT LISP:CHAR NAME)
+        ((LISP:CHAR-EQUAL LISP:CHAR-GREATERP LISP:CHAR-LESSP LISP:CHAR-NOT-EQUAL 
+                LISP:CHAR-NOT-GREATERP LISP:CHAR-NOT-LESSP LISP:CHAR/= LISP:CHAR< LISP:CHAR<= 
+                LISP:CHAR= LISP:CHAR> LISP:CHAR>=)
+         LISP:CHARACTER &REST MORE-CHARACTERS)
+        (LISP:CHECK-TYPE PLACE TYPESPEC &OPTIONAL STRING)
+        ((LISP:CIS LISP:COS LISP:SIN LISP:TAN)
+         RADIANS)
+        ((LISP:CLEAR-INPUT LISP:LISTEN)
+         &OPTIONAL INPUT-STREAM)
+        ((LISP:CLEAR-OUTPUT LISP:FINISH-OUTPUT LISP:FORCE-OUTPUT LISP:FRESH-LINE LISP:TERPRI)
+         &OPTIONAL OUTPUT-STREAM)
+        (LISP:CLOSE STREAM &KEY :ABORT)
+        ((CLRHASH LISP:HASH-TABLE-COUNT)
+         LISP:HASH-TABLE)
+        (LISP:CODE-CHAR CODE &OPTIONAL BITS FONT)
+        (COERCE OBJECT RESULT-TYPE)
+        (LISP:COMPILE NAME &OPTIONAL DEFINITION &KEY :LAP)
+        (LISP:COMPILE-FILE INPUT-PATHNAME &KEY :OUTPUT-FILE :ERROR-FILE :ERRORS-TO-TERMINAL :LAP-FILE
+               :LOAD :FILE-MANAGER-FORMAT :PROCESS-ENTIRE-FILE)
+        (LISP:COMPILER-LET ((CURLYLIST VAR #\| (VAR VALUE))
+                            #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (COMPLEX LISP:REALPART &OPTIONAL IMAGPART)
+        (LISP:COMPUTE-RESTARTS &OPTIONAL CONDITION)
+        (LISP:CONCATENATE RESULT-TYPE &REST SEQUENCES)
+        (COND (CURLYLIST (TEST (CURLYLIST FORM)
+                               #\*))
+              #\*)
+        ((CONS LISP:NRECONC LISP:REVAPPEND RPLACA RPLACD)
+         X Y)
+        ((LISP:COPY-ALIST LISP:COPY-LIST LISP:VALUES-LIST)
+         LIST)
+        (LISP:COPY-READTABLE &OPTIONAL FROM-READTABLE TO-READTABLE)
+        ((LISP:COPY-SEQ LISP:LENGTH LISP:NREVERSE LISP:REVERSE)
+         SEQUENCE)
+        (LISP:COPY-SYMBOL SYM &OPTIONAL COPY-PROPS)
+        ((LISP:COUNT LISP:FIND LISP:POSITION)
+         ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY)
+        ((LISP:COUNT-IF LISP:COUNT-IF-NOT LISP:FIND-IF LISP:FIND-IF-NOT LISP:POSITION-IF 
+                LISP:POSITION-IF-NOT)
+         TEST SEQUENCE &KEY :FROM-END :START :END :KEY)
+        [LISP:CTYPECASE KEYPLACE (CURLYLIST* (TYPE (CURLYLIST* FORM]
+        ((LISP:DECF LISP:INCF)
+         PLACE
+         (SQUARELIST DELTA))
+        (LISP:DECLAIM (CURLYLIST* DECL-SPEC)
+               #\*)
+        (DECLARE (CURLYLIST DECL-SPEC)
+               #\*)
+        ((LISP:DECODE-FLOAT LISP:FLOAT-DIGITS LISP:FLOAT-PRECISION LISP:FLOAT-RADIX 
+                LISP:INTEGER-DECODE-FLOAT)
+         FLOAT)
+        (LISP:DECODE-UNIVERSAL-TIME UNIVERSAL-TIME &OPTIONAL TIME-ZONE)
+        ((LISP:DEFCONSTANT LISP:DEFPARAMETER)
+         NAME INITIAL-VALUE (SQUARELIST LISP:DOCUMENTATION))
+        (DEFINE-CONDITION NAME ((CURLYLIST PARENT-TYPE)
+                                #\*)
+               (SQUARELIST ((CURLYLIST SLOT-SPECIFIER)
+                            #\*)
+                      (CURLYLIST OPTION)
+                      #\*))
+        (LISP:DEFINE-MODIFY-MACRO NAME LAMBDA-LIST LISP:FUNCTION (SQUARELIST DOC-STRING))
+        (LISP:DEFINE-SETF-METHOD ACCESS-FN LAMBDA-LIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        ((DEFMACRO LISP:DEFTYPE LISP:DEFUN)
+         NAME LAMBDA-LIST (CURLYLIST* LISP:DECLARATION #\| DOC-STRING)
+         (CURLYLIST* FORM))
+        (DEFPACKAGE DEFINED-PACKAGE-NAME (CURLYLIST OPTION)
+               #\*)
+        (LISP:DEFSETF ACCESS-FN (CURLYLIST UPDATE-FN (SQUARELIST DOC-STRING)
+                                       #\| LAMBDA-LIST (STORE-VARIABLE)
+                                       (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                                       #\*
+                                       (CURLYLIST FORM)
+                                       #\*))
+        (LISP:DEFSTRUCT NAME-AND-OPTIONS (SQUARELIST DOC-STRING)
+               (CURLYLIST SLOT-DESCRIPTION)
+               #\+)
+        (LISP:DEFVAR NAME (SQUARELIST INITIAL-VALUE (SQUARELIST LISP:DOCUMENTATION)))
+        ((LISP:DELETE LISP:REMOVE)
+         ITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)
+        ((LISP:DELETE-DUPLICATES LISP:REMOVE-DUPLICATES)
+         SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :KEY)
+        ((LISP:DELETE-FILE LISP:FILE-AUTHOR LISP:FILE-WRITE-DATE LISP:PROBE-FILE)
+         FILE)
+        ((LISP:DELETE-IF LISP:DELETE-IF-NOT LISP:REMOVE-IF LISP:REMOVE-IF-NOT)
+         TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY)
+        ((LISP:DENOMINATOR LISP:NUMERATOR)
+         LISP:RATIONAL)
+        ((LISP:DEPOSIT-FIELD DPB)
+         NEWBYTE BYTESPEC INTEGER)
+        (DESTRUCTURING-BIND BIND-PATTERN VALUE &BODY BODY)
+        (LISP:DIGIT-CHAR WEIGHT &OPTIONAL RADIX FONT)
+        (LISP:DIGIT-CHAR-P LISP:CHAR &OPTIONAL RADIX)
+        ((LISP:DIRECTORY LISP:DIRECTORY-NAMESTRING LISP:FILE-NAMESTRING LISP:HOST-NAMESTRING 
+                LISP:NAMESTRING PATHNAME LISP:PATHNAME-DEVICE LISP:PATHNAME-DIRECTORY 
+                LISP:PATHNAME-HOST LISP:PATHNAME-NAME LISP:PATHNAME-TYPE LISP:PATHNAME-VERSION 
+                LISP:TRUENAME)
+         PATHNAME)
+        (LISP:DISASSEMBLE NAME-OR-COMPILED-FUNCTION)
+        ((LISP:DO LISP:DO*)
+         [(CURLYLIST* VAR #\| (VAR (SQUARELIST INIT (SQUARELIST LISP:STEP]
+         (END-TEST (CURLYLIST* RESULT))
+         (CURLYLIST* LISP:DECLARATION)
+         (CURLYLIST* TAG #\| STATEMENT))
+        (LISP:DO-ALL-SYMBOLS (VAR (SQUARELIST RESULT-FORM))
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST TAG #\| STATEMENT)
+               #\*)
+        ((LISP:DO-EXTERNAL-SYMBOLS LISP:DO-SYMBOLS)
+         (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM)))
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (LISP:DOCUMENTATION LISP:SYMBOL DOC-TYPE)
+        (LISP:DOLIST (VAR LISTFORM (SQUARELIST RESULTFORM))
+            (CURLYLIST LISP:DECLARATION)
+            #\*
+            (CURLYLIST TAG #\| STATEMENT)
+            #\*)
+        (LISP:DOTIMES (VAR COUNTFORM (SQUARELIST RESULTFORM))
+            (CURLYLIST LISP:DECLARATION)
+            #\*
+            (CURLYLIST TAG #\| STATEMENT)
+            #\*)
+        (DRIBBLE &OPTIONAL PATHNAME)
+        (ED &OPTIONAL NAME OPTIONS #\= ((CURLYLIST "FILEPKGTYPE" #\| :DISPLAY #\| :NEW)
+                                        #\*))
+        (LISP:ELT SEQUENCE INDEX)
+        (LISP:ENCODE-UNIVERSAL-TIME LISP:SECOND MINUTE HOUR DATE MONTH YEAR &OPTIONAL TIME-ZONE)
+        (LISP:ENOUGH-NAMESTRING PATHNAME &OPTIONAL DEFAULTS)
+        ((EQ EQL LISP:EQUAL LISP:EQUALP)
+         X Y)
+        ((LISP:ERROR LISP:WARN)
+         FORMAT-STRING &REST ARGS)
+        ((LISP:ETYPECASE LISP:TYPECASE)
+         KEYFORM
+         (CURLYLIST (TYPE (CURLYLIST FORM)
+                          #\*))
+         #\*)
+        ((LISP:EVAL LISP:GET-SETF-METHOD LISP:GET-SETF-METHOD-MULTIPLE-VALUE)
+         FORM)
+        (LISP:EVAL-WHEN ((CURLYLIST SITUATION)
+                         #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:EVALHOOK FORM EVALHOOKFN APPLYHOOKFN &OPTIONAL ENV)
+        ((EVENP LISP:INT-CHAR LISP:INTEGER-LENGTH LISP:ISQRT LISP:LOGCOUNT LOGNOT ODDP)
+         INTEGER)
+        ((LISP:EVERY LISP:NOTANY LISP:NOTEVERY LISP:SOME)
+         PREDICATE SEQUENCE &REST MORE-SEQUENCES)
+        ((EXPORT IMPORT LISP:SHADOW LISP:SHADOWING-IMPORT LISP:UNEXPORT)
+         SYMBOLS &OPTIONAL PACKAGE)
+        (LISP:EXPT BASE-NUMBER POWER-NUMBER)
+        (LISP:FILE-LENGTH FILE-STREAM)
+        (LISP:FILE-POSITION FILE-STREAM &OPTIONAL LISP:POSITION)
+        (LISP:FILL SEQUENCE ITEM &KEY :START :END)
+        ((LISP:FILL-POINTER LISP:VECTOR-POP)
+         LISP:VECTOR)
+        (LISP:FIND-ALL-SYMBOLS STRING-OR-SYMBOL)
+        ((LISP:FIND-PACKAGE LISP:NAME-CHAR)
+         NAME)
+        (LISP:FIND-RESTART RESTART-IDENTIFIER &OPTIONAL CONDITION)
+        ((LISP:FIND-SYMBOL LISP:INTERN)
+         STRING &OPTIONAL PACKAGE)
+        ((LISP:FLET LISP:LABELS)
+         ((CURLYLIST (NAME LAMBDA-LIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                           #\*
+                           (CURLYLIST FORM)
+                           #\*))
+          #\*)
+         (CURLYLIST FORM)
+         #\*)
+        (FLOAT LISP:NUMBER &OPTIONAL OTHER)
+        (LISP:FLOAT-SIGN FLOAT1 &OPTIONAL FLOAT2)
+        (LISP:FORMAT DESTINATION CONTROL-STRING &REST ARGUMENTS)
+        (LISP:FUNCALL FN &REST ARGUMENTS)
+        #'FN
+        ((LISP:GCD LOGAND LISP:LOGEQV LISP:LOGIOR LOGXOR)
+         &REST INTEGERS)
+        (LISP:GENSYM &OPTIONAL X)
+        (LISP:GENTEMP &OPTIONAL PREFIX PACKAGE)
+        (GET LISP:SYMBOL INDICATOR &OPTIONAL DEFAULT)
+        ((LISP:GET-DECODED-TIME LISP:GET-INTERNAL-REAL-TIME LISP:GET-INTERNAL-RUN-TIME 
+                LISP:GET-UNIVERSAL-TIME LISP:LISP-IMPLEMENTATION-TYPE 
+                LISP:LISP-IMPLEMENTATION-VERSION LISP:LIST-ALL-PACKAGES LISP:LONG-SITE-NAME 
+                LISP:MACHINE-INSTANCE LISP:MACHINE-TYPE LISP:MACHINE-VERSION 
+                LISP:MAKE-STRING-OUTPUT-STREAM LISP:SHORT-SITE-NAME LISP:SOFTWARE-TYPE 
+                LISP:SOFTWARE-VERSION))
+        (LISP:GET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR &OPTIONAL LISP:READTABLE)
+        (LISP:GET-MACRO-CHARACTER LISP:CHAR &OPTIONAL LISP:READTABLE)
+        (LISP:GET-OUTPUT-STREAM-STRING STRING-OUTPUT-STREAM)
+        (LISP:GET-PROPERTIES PLACE INDICATOR-LIST)
+        (LISP:GETF PLACE INDICATOR &OPTIONAL DEFAULT)
+        (LISP:GETHASH KEY LISP:HASH-TABLE &OPTIONAL DEFAULT)
+        (GO TAG)
+        (HANDLER-BIND ((CURLYLIST (TYPE HANDLER))
+                       #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:HANDLER-CASE EXPRESSION (CURLYLIST (TYPESPEC ((SQUARELIST VAR))
+                                                        (CURLYLIST FORM)
+                                                        #\*))
+               #\*)
+        (IGNORE-ERRORS &BODY FORMS)
+        (LISP:IF TEST
+            THEN
+            (SQUARELIST ELSE))
+        (LISP:IN-PACKAGE NAME)
+        (LISP:IN-PACKAGE LISP:PACKAGE-NAME &KEY :NICKNAMES :USE)
+        ((LISP:INPUT-STREAM-P LISP:OUTPUT-STREAM-P LISP:STREAM-ELEMENT-TYPE)
+         STREAM)
+        (LISP:INVOKE-RESTART RESTART-IDENTIFIER &REST ARGUMENTS)
+        ((LISP:INTERSECTION LISP:NINTERSECTION LISP:NSET-DIFFERENCE LISP:NSET-EXCLUSIVE-OR 
+                LISP:NUNION LISP:SET-DIFFERENCE LISP:SET-EXCLUSIVE-OR LISP:SUBSETP LISP:UNION)
+         LIST1 LIST2 &KEY :TEST :TEST-NOT :KEY)
+        (LAST LIST &OPTIONAL N)
+        (LISP:LCM &REST INTEGERS)
+        ((LDB LISP:LDB-TEST LISP:MASK-FIELD)
+         BYTESPEC INTEGER)
+        (LISP:LDIFF LIST SUBLIST)
+        ((LET LET*)
+         ((CURLYLIST VAR #\| (VAR (SQUARELIST VALUE)))
+          #\*)
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST FORM)
+         #\*)
+        ((LIST LISP:VALUES)
+         &REST ARGS)
+        (LIST* ARG &REST OTHERS)
+        (LISP:LOAD FILENAME &KEY :VERBOSE :PRINT :IF-DOES-NOT-EXIST :PACKAGE :LOADFLG)
+        (LISP:LOCALLY (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:LOG LISP:NUMBER &OPTIONAL BASE)
+        ((LISP:LOGANDC1 LISP:LOGANDC2 LISP:LOGNAND LISP:LOGNOR LISP:LOGORC1 LISP:LOGORC2 LISP:LOGTEST
+                )
+         INTEGER1 INTEGER2)
+        (LISP:LOGBITP INDEX INTEGER)
+        (LISP:LOOP (CURLYLIST LISP::LOOP-CLAUSE)
+               #\*
+               (CURLYLIST TAG #\| EXPR)
+               #\*)
+        (LISP:MACRO-FUNCTION SYMBOL &OPTIONAL ENV)
+        ((LISP:MACROEXPAND LISP:MACROEXPAND-1)
+         FORM &OPTIONAL ENV)
+        (LISP:MACROLET ((CURLYLIST (NAME VARLIST (CURLYLIST LISP:DECLARATION #\| DOC-STRING)
+                                         #\*
+                                         (CURLYLIST FORM)
+                                         #\*))
+                        #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:MAKE-ARRAY DIMENSIONS &KEY :ELEMENT-TYPE :INITIAL-ELEMENT :INITIAL-CONTENTS :ADJUSTABLE
+               :FILL-POINTER :DISPLACED-TO :DISPLACED-INDEX-OFFSET :FATP :EXTENDABLE :READ-ONLY-P 
+               :DISPLACED-TO-BASE)
+        ((LISP:MAKE-BROADCAST-STREAM LISP:MAKE-CONCATENATED-STREAM)
+         &REST STREAMS)
+        (LISP:MAKE-CHAR LISP:CHAR &OPTIONAL BITS FONT)
+        (MAKE-CONDITION TYPE &REST SLOT-INITIALIZATIONS)
+        (LISP:MAKE-DISPATCH-MACRO-CHARACTER LISP:CHAR &OPTIONAL NON-TERMINATING-P LISP:READTABLE)
+        ((LISP:MAKE-ECHO-STREAM LISP:MAKE-TWO-WAY-STREAM)
+         INPUT-STREAM OUTPUT-STREAM)
+        (LISP:MAKE-HASH-TABLE &KEY :TEST :SIZE :REHASH-SIZE :REHASH-THRESHOLD)
+        (LISP:MAKE-LIST SIZE &KEY :INITIAL-ELEMENT)
+        (LISP:MAKE-PACKAGE LISP:PACKAGE-NAME &KEY :NICKNAMES :USE :PREFIX-NAME :INTERNAL-SYMBOLS 
+               :EXTERNAL-SYMBOLS :EXTERNAL-ONLY)
+        (LISP:MAKE-PATHNAME &KEY :HOST :DEVICE :DIRECTORY :NAME :TYPE :VERSION :DEFAULTS :CASE)
+        (LISP:MAKE-RANDOM-STATE &OPTIONAL STATE)
+        (LISP:MAKE-SEQUENCE TYPE SIZE &KEY :INITIAL-ELEMENT)
+        (LISP:MAKE-STRING SIZE &KEY :INITIAL-ELEMENT :ELEMENT-TYPE)
+        (LISP:MAKE-STRING-INPUT-STREAM STRING &OPTIONAL START END)
+        (LISP:MAKE-STRING-OUTPUT-STREAM &KEY :ELEMENT-TYPE)
+        (LISP:MAKE-SYMBOL PRINT-NAME)
+        (MAKE-VECTOR LISP:LENGTH &OPTIONAL TYPE INITIAL-VALUE)
+        (LISP:MAP RESULT-TYPE LISP:FUNCTION SEQUENCE &REST MORE-SEQUENCES)
+        (LISP:MAP-INTO RESULT-SEQUENCE FUNCTION &REST SEQUENCES)
+        ((LISP:MAPC LISP:MAPCAN LISP:MAPCAR LISP:MAPCON LISP:MAPL LISP:MAPLIST)
+         LISP:FUNCTION LIST &REST MORE-LISTS)
+        (LISP:MAPHASH LISP:FUNCTION LISP:HASH-TABLE)
+        ((LISP:MEMBER-IF LISP:MEMBER-IF-NOT)
+         PREDICATE LIST &KEY :KEY)
+        (LISP:MERGE RESULT-TYPE SEQUENCE1 SEQUENCE2 PREDICATE &KEY :KEY)
+        (LISP:MERGE-PATHNAMES PATHNAME &OPTIONAL DEFAULTS DEFAULT-VERSION)
+        ((LISP:MISMATCH LISP:SEARCH)
+         SEQUENCE1 SEQUENCE2 &KEY :FROM-END :TEST :TEST-NOT :KEY :START1 :START2 :END1 :END2)
+        ((LISP:MOD LISP:REM)
+         LISP:NUMBER DIVISOR)
+        (LISP:MULTIPLE-VALUE-BIND ((CURLYLIST VAR)
+                                   #\*)
+               VALUES-FORM
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:MULTIPLE-VALUE-CALL LISP:FUNCTION (CURLYLIST FORM)
+               #\*)
+        ((LISP:MULTIPLE-VALUE-LIST LISP:STEP)
+         FORM)
+        (LISP:MULTIPLE-VALUE-PROG1 FORM (CURLYLIST FORM)
+               #\*)
+        (LISP:MULTIPLE-VALUE-SETQ VARIABLES FORM)
+        ((NOT STRING)
+         X)
+        ((LISP:NSTRING-CAPITALIZE LISP:NSTRING-DOWNCASE LISP:NSTRING-UPCASE LISP:STRING-CAPITALIZE 
+                LISP:STRING-DOWNCASE LISP:STRING-UPCASE)
+         STRING &KEY :START :END)
+        ((LISP:NSUBLIS LISP:SUBLIS)
+         ALIST TREE &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:NSUBST LISP:SUBST)
+         NEW OLD TREE &KEY :TEST :TEST-NOT :KEY)
+        ((LISP:NSUBST-IF LISP:NSUBST-IF-NOT LISP:SUBST-IF LISP:SUBST-IF-NOT)
+         NEW TEST TREE &KEY :KEY)
+        ((LISP:NSUBSTITUTE LISP:SUBSTITUTE)
+         NEWITEM OLDITEM SEQUENCE &KEY :FROM-END :TEST :TEST-NOT :START :END :COUNT :KEY)
+        ((LISP:NSUBSTITUTE-IF LISP:NSUBSTITUTE-IF-NOT LISP:SUBSTITUTE-IF LISP:SUBSTITUTE-IF-NOT)
+         NEWITEM TEST SEQUENCE &KEY :FROM-END :START :END :COUNT :KEY)
+        ((LISP:NTH LISP:NTHCDR)
+         N LIST)
+        (LISP:NTH-VALUE N FORM)
+        (OPEN FILENAME &KEY :DIRECTION :ELEMENT-TYPE :IF-EXISTS :IF-DOES-NOT-EXIST :EXTERNAL-FORMAT)
+        ((LISP:PACKAGE-NAME LISP:PACKAGE-NICKNAMES LISP:PACKAGE-SHADOWING-SYMBOLS 
+                LISP:PACKAGE-USE-LIST LISP:PACKAGE-USED-BY-LIST)
+         PACKAGE)
+        (LISP:PAIRLIS KEYS DATA &OPTIONAL A-LIST)
+        (LISP:PARSE-INTEGER STRING &KEY :START :END :RADIX :JUNK-ALLOWED)
+        (LISP:PARSE-NAMESTRING THING &OPTIONAL HOST DEFAULTS &KEY :START :END :JUNK-ALLOWED)
+        ((LISP:PATHNAME-HOST LISP:PATHNAME-DEVICE LISP:PATHNAME-DIRECTORY LISP:PATHNAME-NAME 
+                LISP:PATHNAME-TYPE)
+         PATHNAME &KEY :CASE)
+        (LISP:PEEK-CHAR &OPTIONAL PEEK-TYPE INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:POP PLACE)
+        ((LISP:PPRINT LISP:PRIN1 LISP:PRINC LISP:PRINT)
+         OBJECT &OPTIONAL OUTPUT-STREAM)
+        (LISP:PRINT-UNREADABLE-OBJECT (LISP::OBJECT STREAM &KEY :TYPE :IDENTITY)
+               (CURLYLIST DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:PROCLAIM DECL-SPEC)
+        ((PROG PROG*)
+         ((CURLYLIST VAR #\| (VAR (SQUARELIST INIT)))
+          #\*)
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (PROG1 LISP:FIRST
+            (CURLYLIST FORM)
+            #\*)
+        (PROG2 LISP:FIRST LISP:SECOND (CURLYLIST FORM)
+               #\*)
+        (LISP:PROGV SYMBOLS LISP:VALUES
+            (CURLYLIST FORM)
+            #\*)
+        (LISP:PROVIDE MODULE-NAME)
+        ((LISP:PSETF LISP:SETF)
+         (CURLYLIST PLACE NEWVALUE)
+         #\*)
+        ((LISP:PSETQ LISP:SETQ)
+         (CURLYLIST VAR FORM)
+         #\*)
+        (LISP:PUSH ITEM PLACE)
+        (LISP:PUSHNEW ITEM LIST &KEY :TEST :TEST-NOT :KEY)
+        'OBJECT
+        (LISP:RANDOM LISP:NUMBER &OPTIONAL STATE)
+        ((LISP:READ LISP:READ-CHAR LISP:READ-CHAR-NO-HANG LISP:READ-LINE)
+         &OPTIONAL INPUT-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:READ-BYTE BINARY-INPUT-STREAM &OPTIONAL EOF-ERROR-P EOF-VALUE)
+        (LISP:READ-DELIMITED-LIST LISP:CHAR &OPTIONAL INPUT-STREAM RECURSIVE-P)
+        (LISP:READ-FROM-STRING STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY :START :END 
+               :PRESERVE-WHITESPACE)
+        (LISP:READ-PRESERVING-WHITESPACE &OPTIONAL IN-STREAM EOF-ERROR-P EOF-VALUE RECURSIVE-P)
+        (LISP:REDUCE LISP:FUNCTION SEQUENCE &KEY :FROM-END :START :END :INITIAL-VALUE)
+        (LISP:REMF PLACE INDICATOR)
+        (REMHASH KEY LISP:HASH-TABLE)
+        (REMPROP LISP:SYMBOL INDICATOR)
+        (LISP:RENAME-FILE FILE NEW-NAME)
+        (LISP:RENAME-PACKAGE PACKAGE NEW-NAME &OPTIONAL NEW-NICKNAMES)
+        (LISP:REPLACE SEQUENCE1 SEQUENCE2 &KEY :START1 :END1 :START2 :END2)
+        (LISP:REQUIRE MODULE-NAME &OPTIONAL PATHNAME)
+        (LISP:RESTART-BIND ((CURLYLIST (NAME FUNCTION (CURLYLIST KEYWORD VALUE)
+                                             #\*))
+                            #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:RESTART-CASE EXPRESSION (CURLYLIST (CASE-NAME ARG-LIST (CURLYLIST KEYWORD VALUE)
+                                                        #\*
+                                                        (CURLYLIST FORM)
+                                                        #\*))
+               #\*)
+        (RETURN (SQUARELIST RESULT))
+        (LISP:RETURN-FROM NAME (SQUARELIST RESULT))
+        (LISP:ROTATEF (CURLYLIST PLACE)
+               #\*)
+        (LISP:SBIT SIMPLE-BIT-ARRAY &REST SUBSCRIPTS)
+        (LISP:SCALE-FLOAT FLOAT INTEGER)
+        (LISP:SCHAR LISP:SIMPLE-STRING INDEX)
+        (SET LISP:SYMBOL VALUE)
+        (LISP:SET-CHAR-BIT LISP:CHAR NAME NEWVALUE)
+        (LISP:SET-DISPATCH-MACRO-CHARACTER DISP-CHAR SUB-CHAR LISP:FUNCTION &OPTIONAL LISP:READTABLE)
+        (LISP:SET-MACRO-CHARACTER LISP:CHAR LISP:FUNCTION &OPTIONAL NON-TERMINATING-P LISP:READTABLE)
+        (LISP:SET-SYNTAX-FROM-CHAR TO-CHAR FROM-CHAR &OPTIONAL TO-READTABLE FROM-READTABLE)
+        (LISP:SHIFTF (CURLYLIST PLACE)
+               #\+ NEWVALUE)
+        (SIGNAL DATUM &REST ARGUMENTS)
+        (LISP:SLEEP SECONDS)
+        ((LISP:SORT LISP:STABLE-SORT)
+         SEQUENCE PREDICATE &KEY :KEY)
+        ((STORE-VALUE USE-VALUE)
+         NEW-VALUE &OPTIONAL CONDITION)
+        (LISP:STREAM-EXTERNAL-FORMAT STREAM)
+        ((STRING-EQUAL LISP:STRING-GREATERP LISP:STRING-LESSP LISP:STRING-NOT-EQUAL 
+                LISP:STRING-NOT-GREATERP LISP:STRING-NOT-LESSP LISP:STRING/= LISP:STRING< 
+                LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>=)
+         STRING1 STRING2 &KEY :START1 :END1 :START2 :END2)
+        ((LISP:STRING-LEFT-TRIM LISP:STRING-RIGHT-TRIM LISP:STRING-TRIM)
+         CHARACTER-BAG STRING)
+        (LISP:SUBSEQ SEQUENCE START &OPTIONAL END)
+        (LISP:SUBTYPEP TYPE1 TYPE2)
+        (LISP:SVREF LISP:SIMPLE-VECTOR INDEX)
+        (LISP::SYMBOL-MACROLET ((CURLYLIST (LISP::VAR LISP::EXPANSION))
+                                #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST LISP::FORM)
+               #\*)
+        ((LISP:SYMBOL-NAME LISP:SYMBOL-PACKAGE)
+         SYM)
+        (LISP:TAGBODY (CURLYLIST TAG #\| STATEMENT)
+               #\*)
+        (TAILP SUBLIST LIST)
+        (THE VALUE-TYPE FORM)
+        (LISP:THROW TAG RESULT)
+        (TIME FORM &KEY :REPEAT :OUTPUT :DATA-TYPES)
+        ((TRACE UNTRACE)
+         (CURLYLIST FUNCTION-NAME)
+         #\*)
+        (LISP:TRANSLATE-PATHNAME PATHNAME &KEY)
+        (LISP:TRANSLATE-PATHNAME LISP::SOURCE LISP::FROM-WILDNAME LISP::TO-WILDNAME &KEY)
+        (LISP:TREE-EQUAL X Y &KEY :TEST :TEST-NOT)
+        (TYPEP OBJECT TYPE)
+        (LISP:UNINTERN LISP:SYMBOL &OPTIONAL PACKAGE)
+        ((LISP:UNLESS LISP:WHEN)
+         TEST
+         (CURLYLIST FORM)
+         #\*)
+        (LISP:UNREAD-CHAR LISP:CHARACTER &OPTIONAL INPUT-STREAM)
+        (LISP:UNUSE-PACKAGE PACKAGES-TO-UNUSE &OPTIONAL PACKAGE)
+        (LISP:UNWIND-PROTECT
+            PROTECTED-FORM
+            (CURLYLIST CLEANUP-FORM)
+            #\*)
+        (LISP:USE-PACKAGE PACKAGES-TO-USE &OPTIONAL PACKAGE)
+        (LISP:USER-HOMEDIR-PATHNAME &OPTIONAL HOST)
+        (LISP:VECTOR &REST OBJECTS)
+        (LISP:VECTOR-PUSH NEW-ELEMENT LISP:VECTOR)
+        (LISP:VECTOR-PUSH-EXTEND NEW-ELEMENT LISP:VECTOR &OPTIONAL EXTENSION)
+        (LISP:WILD-PATHNAME-P PATHNAME &OPTIONAL LISP::FIELD-KEY)
+        (LISP:WITH-COMPILATION-UNIT ((CURLYLIST LISP::OPTION-NAME LISP::OPTION-VALUE)
+                                     #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-CONDITION-RESTARTS CONDITION-FORM RESTARTS-FORM (CURLYLIST DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-INPUT-FROM-STRING (VAR STRING (CURLYLIST LISP:KEYWORD VALUE)
+                                          #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-HASH-TABLE-ITERATOR (LISP::MNAME LISP:HASH-TABLE)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OPEN-FILE (STREAM FILENAME (CURLYLIST OPTIONS)
+                                    #\*)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OPEN-STREAM (VAR STREAM)
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-OUTPUT-TO-STRING (VAR (SQUARELIST STRING (SQUARELIST ":ELEMENT-TYPE" TYPE)))
+               (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-PACKAGE-ITERATOR (MNAME PACKAGE-LIST (CURLYLIST LISP::SYMBOL-TYPE)
+                                           #\+)
+               (CURLYLIST LISP::FORM)
+               #\*)
+        (LISP:WITH-SIMPLE-RESTART (NAME FORMAT-STRING (CURLYLIST FORMAT-ARGUMENT)
+                                        #\*)
+               (CURLYLIST FORM)
+               #\*)
+        (LISP:WITH-STANDARD-IO-SYNTAX (CURLYLIST LISP:DECLARATION)
+               #\*
+               (CURLYLIST FORM)
+               #\*)
+        (WRITE OBJECT &KEY :STREAM :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE :GENSYM
+               :ARRAY :READABLY :RIGHT-MARGIN :MISER-WIDTH :LINES :PPRINT-DISPATCH)
+        (LISP:WRITE-BYTE INTEGER BINARY-OUTPUT-STREAM)
+        (LISP:WRITE-CHAR LISP:CHARACTER &OPTIONAL OUTPUT-STREAM)
+        ((LISP:WRITE-LINE LISP:WRITE-STRING)
+         STRING &OPTIONAL OUTPUT-STREAM &KEY :START :END)
+        (LISP:WRITE-TO-STRING OBJECT &KEY :ESCAPE :RADIX :BASE :CIRCLE :PRETTY :LEVEL :LENGTH :CASE 
+               :GENSYM :ARRAY :READABLY :RIGHT-MARGIN :MISER-WIDTH :LINES :PPRINT-DISPATCH)
+        ((LISP:Y-OR-N-P LISP:YES-OR-NO-P)
+         &OPTIONAL FORMAT-STRING &REST ARGUMENTS)))
+
+(RPAQQ *XCL-ARGINFO-LIST*

+       ((ADD-EXEC &KEY :PROFILE :REGION :TTY :EXEC :ID)
+        (ASET NEWVALUE ARRAY &REST INDICES)
+        (CATCH-ABORT PRINT-FORM &BODY FORMS)
+        (CONDITION-CASE FORM (CURLYLIST (TYPE ((SQUARELIST VAR))
+                                              (CURLYLIST FORM)
+                                              #\*))
+               #\*)
+        ((CONDITION-HANDLER CONDITION-REPORTER)
+         TYPE)
+        (COMPILER:COPY-ENV-WITH-FUNCTION ENVIRONMENT FUNCTION &OPTIONAL KIND EXP-FN)
+        (COMPILER:COPY-ENV-WITH-VARIABLE ENVIRONMENT VARIABLE &OPTIONAL KIND)
+        (DEBUG &OPTIONAL DATUM &REST ARGUMENTS)
+        (DEF-DEFINE-TYPE NAME DESCRIPTION-STRING &KEY :UNDEFINER)
+        (DEFAULT-PROCEED-TEST PROCEED-CASE-NAME)
+        (DEFCOMMAND NAME ARGUMENT-LIST &REST BODY)
+        (DEFDEFINER (CURLYLIST NAME #\| (NAME (CURLYLIST OPTION-CLAUSE)
+                                              #\*))
+               TYPE ARGLIST &BODY BODY)
+        (DEFGLOBALPARAMETER NAME INITIAL-VALUE &OPTIONAL DOC-STRING)
+        (DEFGLOBALVAR NAME &OPTIONAL INITIAL-VALUE DOC-STRING)
+        (DEFINE-PROCEED-FUNCTION NAME (SQUARELIST KEYWORD VALUE)
+               #\* &REST VARIABLES)
+        (DEFINLINE NAME ARG-LIST &BODY BODY)
+        (DEFOPTIMIZER FORM-NAME (SQUARELIST OPT-NAME)
+               (SQUARELIST ARG-LIST (SQUARELIST DECL #\| DOC-STRING)
+                      #\*)
+               BODY)
+        ((XCL:DO-INTERNAL-SYMBOLS DO-LOCAL-SYMBOLS)
+         (VAR (SQUARELIST PACKAGE (SQUARELIST RESULT-FORM)))
+         (CURLYLIST LISP:DECLARATION)
+         #\*
+         (CURLYLIST TAG #\| STATEMENT)
+         #\*)
+        (EXEC &KEY :TOP-LEVEL-P :WINDOW :TITLE :COMMAND-TABLES :ENVIRONMENT :PROMPT :FUNCTION 
+              :PROFILE :ID)
+        (EXEC-EVAL FORM &OPTIONAL ENVIRONMENT &KEY :PROMPT :ID :TYPE)
+        (EXEC-FORMAT CONTROL-STRING &REST ARGUMENTS)
+        ((EXTENDABLE-ARRAY-P READ-ONLY-ARRAY-P)
+         ARRAY)
+        (FILL-VECTOR VECTOR VALUE &KEY :START :END)
+        (GLOBALIZE NAMESTRINGS &OPTIONAL PACKAGE)
+        (INVOKE-PROCEED-CASE PROCEED-CASE &REST VALUES)
+        (COMPILER:MAKE-CONTEXT &KEY :TOP-LEVEL-P :VALUES-USED :PREDICATE-P)
+        (PARSE-BODY BODY ENVIRONMENT &OPTIONAL DOC-STRING-ALLOWED?)
+        (PROCEED-CASE FORM (CURLYLIST (PROCEED-FUNCTION-NAME ARGLIST (SQUARELIST KEYWORD VALUE)
+                                             #\*
+                                             (CURLYLIST BODY-FORM)
+                                             #\*))
+               #\*)
+        ((XCL:SET-DEFAULT-EXEC-TYPE XCL:SET-EXEC-TYPE)
+         NAME)
+        (UNDOABLY (CURLYLIST FORMS))
+        (UNDOABLY-SETF (CURLYLIST PLACE VALUE)
+               #\*)))
+
+(LISP:DEFUN ARGINFO-MUNG
 (LST)
+
+   (* ;; "Flattens list elements of LST into a single top-level list of characters and words, recognizing special directives (SQUARELIST . things) and (CURLYLIST . things) to mean turn it into [things] and {things}, respectively.")

+
+   [FOR
 THING IN
 LST JOIN
 (COND
+                                         [(LISP:CONSP THING)
+                                          (CASE (CAR THING)
+                                              (SQUARELIST (CONS #\[ (NCONC1 (ARGINFO-MUNG

+                                                                             (CDR THING))
+                                                                           #\])))
+                                              (CURLYLIST (CONS #\{ (NCONC1 (ARGINFO-MUNG

+                                                                            (CDR THING))
+                                                                          #\})))
+                                              (CURLYLIST* (CONS #\{ (NCONC (ARGINFO-MUNG

+                                                                            (CDR THING))
+                                                                           (LIST #\} #\*))))
+                                              (LISP:OTHERWISE (CONS #\( (NCONC1 (ARGINFO-MUNG

+                                                                                 THING)
+                                                                               #\)))))]
+                                         (T (LIST THING])
+
+(LISP:DEFUN CLSMARTEN
 (FNLIST)
+
+   (* ;; "Transfer arg info from entries in FNLIST to the ARGNAMES props of those fns that need it.  Format of an entry in FNLIST is (Functions . StylizedArgInfo), where Functions can be a symbol or list of symbols.")

+
+   [LET ((NOSPELLFLG T))                                     (* ; 
+
                                                           "Tell SMARTARGLIST not to try too hard")

+        (DECLARE
 (LISP:SPECIAL NOSPELLFLG))
+        (LISP:DOLIST (PAIR FNLIST)
+            [LET (NEWARGS KNOWNARGS)
+                 (LISP:DOLIST [FN (OR (LISTP (CAR PAIR))
+                                      (LIST (CAR PAIR]
+                     (LISP:UNLESS (AND [SETQ KNOWNARGS (NLSETQ (SMARTARGLIST
+                                                                FN
+                                                                (MEMB (ARGTYPE FN)
+                                                                      '(0 2]
+                                       (LISP:LISTP (SETQ KNOWNARGS (CAR KNOWNARGS)))
+                                       (NOT (LISP:MACRO-FUNCTION FN)))
+
+                         (* ;; "Only do this for fns for which SMARTARGLIST doesn't know the answer (something other than an atomic arglist) already.  Also ignore macros to override arglists provided by DEFMACRO.  The ARGTYPE check means try EXPLAINFLG=T in the case where the function is already defined as a lambda (don't want to do that for macros, since SMARTARGLIST would then fake something out of a macro/dmacro prop).  Format of ARGNAMES prop for this kind of guy is (NIL PrettyArgs . InterlispArgs).")

+
+                         (LISP:SETF (GET FN 'ARGNAMES)
+                                (LIST* NIL [OR NEWARGS (SETQ NEWARGS (ARGINFO-MUNG
 (CDR PAIR]
+                                       KNOWNARGS))))])])
+(DECLARE%: DONTEVAL@LOAD DOCOPY 
+
+(CLSMARTEN
 *CL-ARGINFO-LIST*)
+
+(CLSMARTEN
 *XCL-ARGINFO-LIST*)
+
+(SETQ *CL-ARGINFO-LIST* (SETQ *XCL-ARGINFO-LIST* 'NOBIND))
+)
+
+(PUTPROPS CMLSMARTARGS
 FILETYPE
 :COMPILE-FILE)
+(PUTPROPS CMLSMARTARGS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1989 1990 1991 1992 1993)
+)
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLSTRING

@@ -0,0 +1,567 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 15:18:00" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;2"
 30461  
+
+      previous date%: "29-Aug-91 22:57:51" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLSTRING.;1")
+
+
+(* ; "
+Copyright (c) 1985, 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLSTRINGCOMS)
+
+(RPAQQ CMLSTRINGCOMS

+       (
+        (* ;; "run-time support ")

+
+        (FUNCTIONS LISP::SIMPLE-STRING= LISP::SIMPLE-STRING-EQUAL)
+        (FUNCTIONS %%STRING-BASE-COMPARE %%STRING-BASE-COMPARE-EQUAL %%STRING-UPCASE 
+               %%STRING-DOWNCASE)
+        
+        (* ;; "User entry points ")

+
+        (FUNCTIONS LISP:MAKE-STRING LISP:NSTRING-CAPITALIZE LISP:NSTRING-DOWNCASE LISP:NSTRING-UPCASE
+               STRING LISP:STRING-CAPITALIZE LISP:STRING-DOWNCASE STRING-EQUAL LISP:STRING-GREATERP 
+               LISP:STRING-LEFT-TRIM LISP:STRING-LESSP LISP:STRING-NOT-EQUAL LISP:STRING-NOT-GREATERP
+               LISP:STRING-NOT-LESSP LISP:STRING-RIGHT-TRIM LISP:STRING-TRIM LISP:STRING-UPCASE 
+               LISP:STRING/= LISP:STRING< LISP:STRING<= LISP:STRING= LISP:STRING> LISP:STRING>=)
+        (OPTIMIZERS LISP:STRING= STRING-EQUAL)
+        
+        (* ;; "Internal macros  ")

+
+        (DECLARE%: DONTCOPY DOEVAL@COMPILE (FUNCTIONS WITH-ONE-STRING WITH-ONE-STRING-ONLY 
+                                                  WITH-STRING WITH-TWO-UNPACKED-STRINGS 
+                                                  %%UNPACK-STRING %%ADJUST-FOR-OFFSET %%CHECK-BOUNDS
+                                                  %%PARSE-STRING-ARGS %%STRING-LENGTH))
+        
+        (* ;; "Compiler options")

+
+        (PROP FILETYPE CMLSTRING)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY (LOCALVARS . T))))
+
+
+
+(* ;; "run-time support ")

+
+
+(LISP:DEFUN LISP::SIMPLE-STRING=
 (STRING1 STRING2)
+   [LET ((END1 (%%STRING-LENGTH
 STRING1))
+         (END2 (%%STRING-LENGTH
 STRING2)))
+        (LISP:IF (EQ END1 END2)
+            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+                 (%%UNPACK-STRING
 STRING1 BASE1 OFFSET1 TYPENUMBER1)
+                 (%%UNPACK-STRING
 STRING2 BASE2 OFFSET2 TYPENUMBER2)
+                 (LISP:IF (NOT (EQ 0 OFFSET1))
+                     (SETQ END1 (+ END1 OFFSET1)))
+                 (LISP:IF (NOT (EQ 0 OFFSET2))
+                     (SETQ END2 (+ END2 OFFSET2)))
+                 (EQ END1 (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 OFFSET1 END1
+                                 OFFSET2 END2))))])
+
+(LISP:DEFUN LISP::SIMPLE-STRING-EQUAL
 (STRING1 STRING2)
+   [LET ((END1 (%%STRING-LENGTH
 STRING1))
+         (END2 (%%STRING-LENGTH
 STRING2)))
+        (LISP:IF (EQ END1 END2)
+            (LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+                 (%%UNPACK-STRING
 STRING1 BASE1 OFFSET1 TYPENUMBER1)
+                 (%%UNPACK-STRING
 STRING2 BASE2 OFFSET2 TYPENUMBER2)
+                 (LISP:IF (NOT (EQ 0 OFFSET1))
+                     (SETQ END1 (+ END1 OFFSET1)))
+                 (LISP:IF (NOT (EQ 0 OFFSET2))
+                     (SETQ END2 (+ END2 OFFSET2)))
+                 (EQ END1 (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                 OFFSET1 END1 OFFSET2 END2))))])
+
+(LISP:DEFUN %%STRING-BASE-COMPARE
 (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 END2)
+
+   (* ;; "Return index into base1 of first inequality ")

+
+   (* ;; "Can use eq for character comparisons because they are immediate datatypes. Can use eq for numeric equality since Indices are always in the fixnum range")

+
+   (LISP:IF (EQ START1 START2)
+       (LISP:DO ((INDEX START1 (LISP:1+ INDEX))
+                 (ENDINDEX (MIN END1 END2)))
+                ([OR (EQ INDEX ENDINDEX)
+                     (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                              (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
+                 INDEX))
+       (LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
+                 (INDEX2 START2 (LISP:1+ INDEX2))
+                 (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
+                ([OR (EQ INDEX1 ENDINDEX)
+                     (NOT (EQ (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)
+                              (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
+                 INDEX1))))
+
+(LISP:DEFUN %%STRING-BASE-COMPARE-EQUAL
 (BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 END1 START2 
+                                                   END2)
+
+   (* ;; "Return index into base1 of first case insensitive  inequality ")

+
+   (* ;; "Can use eq for character comparisons because they are immediate datatypes. ")

+
+   (* ;; "Char-upcase has been expanded out and simplified below.")

+
+   (LISP:IF (EQ START1 START2)
+       (LISP:DO ((INDEX START1 (LISP:1+ INDEX))
+                 (ENDINDEX (MIN END1 END2)))
+                ([OR (EQ INDEX ENDINDEX)
+                     (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)))
+                              (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX]
+                 INDEX))
+       (LISP:DO [(INDEX1 START1 (LISP:1+ INDEX1))
+                 (INDEX2 START2 (LISP:1+ INDEX2))
+                 (ENDINDEX (MIN END1 (+ START1 (- END2 START2]
+                ([OR (EQ INDEX1 ENDINDEX)
+                     (NOT (EQ (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX1)))
+                              (%%CHAR-UPCASE-CODE (\LOLOC (%%ARRAY-READ BASE2 TYPENUMBER2 INDEX2]
+                 INDEX1))))
+
+(LISP:DEFUN %%STRING-UPCASE
 (STRING
 START END)
+
+   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively upcases string and returns it ")

+
+   (LET ((BASE (%%ARRAY-BASE STRING))
+         (OFFSET (%%ARRAY-OFFSET STRING))
+         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
+        (%%ADJUST-FOR-OFFSET
 START END OFFSET)
+        (LISP:DO ((INDEX START (LISP:1+ INDEX)))
+                 ((EQ INDEX END)
+                  STRING)
+            (%%ARRAY-WRITE (LISP:CHAR-UPCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
+                   BASE TYPENUMBER INDEX))))
+
+(LISP:DEFUN %%STRING-DOWNCASE
 (STRING
 START END)
+
+   (* ;; "Assumes string is a string. Start and end define a subsequence. Destructively downcases string and returns it ")

+
+   (LET ((BASE (%%ARRAY-BASE STRING))
+         (OFFSET (%%ARRAY-OFFSET STRING))
+         (TYPENUMBER (%%ARRAY-TYPE-NUMBER STRING)))
+        (%%ADJUST-FOR-OFFSET
 START END OFFSET)
+        (LISP:DO ((INDEX START (LISP:1+ INDEX)))
+                 ((EQ INDEX END)
+                  STRING)
+            (%%ARRAY-WRITE (LISP:CHAR-DOWNCASE (%%ARRAY-READ BASE TYPENUMBER INDEX))
+                   BASE TYPENUMBER INDEX))))
+
+
+
+(* ;; "User entry points ")

+
+
+(LISP:DEFUN LISP:MAKE-STRING
 (SIZE &KEY (ELEMENT-TYPE 'LISP:CHARACTER)
+                                       (INITIAL-ELEMENT NIL INITIAL-ELEMENT-P)
+                                       FATP)
+   "Makes a simple string"
+   (LET ((STRING
 (MAKE-VECTOR SIZE :ELEMENT-TYPE ELEMENT-TYPE :FATP FATP)))
+        (LISP:IF INITIAL-ELEMENT-P (FILL-ARRAY STRING INITIAL-ELEMENT))
+        STRING))
+
+(LISP:DEFUN LISP:NSTRING-CAPITALIZE
 (STRING
 &KEY START END)
+   "Given a string, returns it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
+   [WITH-ONE-STRING-ONLY
 STRING START END (LISP:DO ((INDEX START (LISP:1+ INDEX))
+                                                        (ALPHA-P NIL)
+                                                        (WAS-ALPHA-P NIL ALPHA-P)
+                                                        CHAR)
+                                                       ((EQ INDEX END)
+                                                        STRING)
+                                                  (SETQ CHAR (LISP:CHAR STRING INDEX))
+                                                  (SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
+                                                  (LISP:SETF (LISP:CHAR STRING INDEX)
+                                                         (LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
+                                                             (LISP:CHAR-UPCASE CHAR)
+                                                             (LISP:CHAR-DOWNCASE CHAR))))])
+
+(LISP:DEFUN LISP:NSTRING-DOWNCASE
 (STRING
 &KEY START END)
+   "Given a string, returns that string with all uppercase alphabetic characters converted to lowercase."
+   (WITH-ONE-STRING-ONLY
 STRING START END (%%STRING-DOWNCASE
 STRING START END)))
+
+(LISP:DEFUN LISP:NSTRING-UPCASE
 (STRING
 &KEY START END)
+   "Given a string, returns that string with all lower case alphabetic characters converted to uppercase."
+   (WITH-ONE-STRING-ONLY
 STRING START END (%%STRING-UPCASE
 STRING START END)))
+
+(LISP:DEFUN STRING
 (X)
+   "Coerces X into a string. If X is a string, X is returned. If X is a symbol, X's pname is returned. If X is a character then a one element string containing that character is returned. If X cannot be coerced into a string, an error occurs."
+   (LISP:TYPECASE X
+       (STRING X)
+       (LISP:SYMBOL (LISP:SYMBOL-NAME X))
+       (LISP:CHARACTER (LISP:MAKE-STRING
 1 :INITIAL-ELEMENT X))
+       (LISP:OTHERWISE (LISP:ERROR "~S cannot be coerced into a string" X))))
+
+(LISP:DEFUN LISP:STRING-CAPITALIZE
 (STRING
 &KEY START END)
+   "Given a string, returns a new string that is a copy of it with the first letter of every word in uppercase and all other letters in lowercase. A word is defined to be a sequence of alphanumeric characters delimited by non-alphanumeric characters"
+   (WITH-ONE-STRING
 STRING START END (LET ((NEW-STRING (LISP:MAKE-STRING
 SLEN)))
+                                              (LISP:DOTIMES (INDEX START)
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:CHAR STRING INDEX)))
+                                              (LISP:DO ((INDEX START (LISP:1+ INDEX))
+                                                        (ALPHA-P NIL)
+                                                        (WAS-ALPHA-P NIL ALPHA-P)
+                                                        CHAR)
+                                                       ((EQ INDEX END))
+                                                  (SETQ CHAR (LISP:CHAR STRING INDEX))
+                                                  (SETQ ALPHA-P (LISP:ALPHANUMERICP CHAR))
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:IF (AND ALPHA-P (NOT WAS-ALPHA-P))
+                                                             (LISP:CHAR-UPCASE CHAR)
+                                                             (LISP:CHAR-DOWNCASE CHAR))))
+                                              (LISP:DO ((INDEX END (LISP:1+ INDEX)))
+                                                       ((EQ INDEX SLEN))
+                                                  (LISP:SETF (LISP:SCHAR NEW-STRING INDEX)
+                                                         (LISP:CHAR STRING INDEX)))
+                                              NEW-STRING)))
+
+(LISP:DEFUN LISP:STRING-DOWNCASE
 (STRING
 &KEY START END)
+   "Given a string, returns a new string that is a copy of it with all uppercase case alphabetic characters converted to lowercase."
+   (WITH-ONE-STRING
 STRING START END (%%STRING-DOWNCASE
 (COPY-VECTOR STRING (
+
                                                                                   LISP:MAKE-STRING

+                                                                                     SLEN))
+                                                START END)))
+
+(LISP:DEFUN STRING-EQUAL
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case insensitive equality"
+   (LISP:IF (OR START1 END1 START2 END2)
+       [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+              (LISP:IF (EQ SLEN1 SLEN2)
+                  (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                         (EQ END1 (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 
+                                         TYPENUMBER2 START1 END1 START2 END2))))]
+       (LISP::SIMPLE-STRING-EQUAL
 STRING1 STRING2)))
+
+(LISP:DEFUN LISP:STRING-GREATERP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING>"
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (LISP:IF (> SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-LEFT-TRIM
 (CHAR-BAG STRING)
+   "Trim only on left"
+   (WITH-STRING
 STRING (LET [(LEFT-END (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
+                                                    ((OR (EQ INDEX SLEN)
+                                                         (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                     CHAR-BAG)))
+                                                     INDEX))]
+                                (LISP:SUBSEQ STRING LEFT-END SLEN))))
+
+(LISP:DEFUN LISP:STRING-LESSP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING<"
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (LISP:IF (< SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-NOT-EQUAL
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two string for case insensitive equality"
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                     START1 END1 START2 END2)))
+                      (LISP:IF (AND (EQ INDEX END1)
+                                    (EQ SLEN1 SLEN2))
+                          NIL
+                          (- INDEX OFFSET1))])
+
+(LISP:DEFUN LISP:STRING-NOT-GREATERP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING<="
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (- INDEX OFFSET1))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR-NOT-GREATERP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-NOT-LESSP
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Case insensitive version of STRING>="
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE-EQUAL
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                      START1 END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (- INDEX OFFSET1))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR-NOT-LESSP (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING-RIGHT-TRIM
 (CHAR-BAG STRING)
+   "Trim only on right"
+   (WITH-STRING
 STRING (LET [(RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
+                                                             (LISP:1- INDEX)))
+                                                     ((OR (< INDEX 0)
+                                                          (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                      CHAR-BAG)))
+                                                      (LISP:1+ INDEX)))]
+                                (LISP:SUBSEQ STRING 0 RIGHT-END))))
+
+(LISP:DEFUN LISP:STRING-TRIM
 (CHAR-BAG STRING)
+
+   (* ;; "Given a set of characters (a list or string) and a string, returns a copy of the string with the characters in the set removed from both ends.")

+
+   (WITH-STRING
 STRING (LET* [(LEFT-END (LISP:DO ((INDEX 0 (LISP:1+ INDEX)))
+                                                     ((OR (EQ INDEX SLEN)
+                                                          (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                      CHAR-BAG)))
+                                                      INDEX)))
+                                  (RIGHT-END (LISP:DO ((INDEX (LISP:1- SLEN)
+                                                              (LISP:1- INDEX)))
+                                                      ((OR (< INDEX LEFT-END)
+                                                           (NOT (LISP:FIND (LISP:CHAR STRING INDEX)
+                                                                       CHAR-BAG)))
+                                                       (LISP:1+ INDEX)))]
+                                 (LISP:SUBSEQ STRING LEFT-END RIGHT-END))))
+
+(LISP:DEFUN LISP:STRING-UPCASE
 (STRING
 &KEY START END)
+   "Given a string, returns a new string that is a copy of it with all lower case alphabetic characters converted to uppercase."
+   (WITH-ONE-STRING
 STRING START END (%%STRING-UPCASE
 (COPY-VECTOR STRING (LISP:MAKE-STRING

+                                                                                   SLEN))
+                                                START END)))
+
+(LISP:DEFUN LISP:STRING/=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case sensitive inequality"
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1 
+                                     END1 START2 END2)))
+                      (LISP:IF (AND (EQ INDEX END1)
+                                    (EQ SLEN1 SLEN2))
+                          NIL
+                          (- INDEX OFFSET1))])
+
+(LISP:DEFUN LISP:STRING<
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "A string A is less than a string B if in the first position in which they differ the character of A is less than the corresponding character of B according to char< or if string A is a proper prefix of string B (of shorter length and matching in all the characters of A). Returns either NIL or an index into STRING1"
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (LISP:IF (< SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR< (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING<=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ INDEX END1)
+                           (- INDEX OFFSET1))
+                          ((EQ (- INDEX START1)
+                               SLEN2)
+                           NIL)
+                          ((LISP:CHAR<= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   "Compare two strings for case sensitive equality"
+   (LISP:IF (OR START1 END1 START2 END2)
+       [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+              (LISP:IF (EQ SLEN1 SLEN2)
+                  (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                         (EQ END1 (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 
+                                         START1 END1 START2 END2))))]
+       (LISP::SIMPLE-STRING=
 STRING1 STRING2)))
+
+(LISP:DEFUN LISP:STRING>
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (LISP:IF (> SLEN1 SLEN2)
+                                  (- INDEX OFFSET1)))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR> (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(LISP:DEFUN LISP:STRING>=
 (STRING1 STRING2 &KEY START1 END1 START2 END2)
+   [%%PARSE-STRING-ARGS
 STRING1 STRING2 START1 END1 START2 END2
+          (WITH-TWO-UNPACKED-STRINGS
 STRING1 STRING2 START1 END1 START2 END2
+                 (LET* ((INDEX (%%STRING-BASE-COMPARE
 BASE1 TYPENUMBER1 BASE2 TYPENUMBER2 START1
+                                      END1 START2 END2))
+                        (REL-INDEX (- INDEX START1)))
+                       (COND
+                          ((EQ REL-INDEX SLEN2)
+                           (- INDEX OFFSET1))
+                          ((EQ INDEX END1)
+                           NIL)
+                          ((LISP:CHAR>= (%%ARRAY-READ BASE1 TYPENUMBER1 INDEX)
+                                  (%%ARRAY-READ BASE2 TYPENUMBER2 (+ START2 REL-INDEX)))
+                           (- INDEX OFFSET1])
+
+(DEFOPTIMIZER LISP:STRING=
 (STRING1 STRING2 &REST OPTIONS)
+                               (LISP:IF OPTIONS
+                                   'COMPILER:PASS
+                                   `(LISP::SIMPLE-STRING=
 ,STRING1 ,STRING2)))
+
+(DEFOPTIMIZER STRING-EQUAL
 (STRING1 STRING2 &REST OPTIONS)
+                               (LISP:IF OPTIONS
+                                   'COMPILER:PASS
+                                   `(LISP::SIMPLE-STRING-EQUAL
 ,STRING1 ,STRING2)))
+
+
+
+(* ;; "Internal macros  ")

+
+(DECLARE%: DONTCOPY DOEVAL@COMPILE 
+
+(DEFMACRO WITH-ONE-STRING
 (STRING
 START END &REST FORMS)
+   "WITH-ONE-STRING is used to set up string operations. The keywords are parsed, and STRING is coerced into a string. SLEN is bound to the string length"
+   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
+         (%%CHECK-BOUNDS
 ,START ,END SLEN)
+         ,@FORMS))
+
+(DEFMACRO WITH-ONE-STRING-ONLY
 (STRING
 START END &REST FORMS)
+
+   (* ;; "Like WITH-ONE-STRING but only strings allowed")

+
+   `(PROGN (LISP:IF (NOT (LISP:STRINGP ,STRING))
+               (LISP:ERROR 'CONDITIONS:SIMPLE-TYPE-ERROR :EXPECTED-TYPE 'STRING :CULPRIT ,STRING))
+           (LET [(SLEN (VECTOR-LENGTH ,STRING]
+                (%%CHECK-BOUNDS
 ,START ,END SLEN)
+                ,@FORMS)))
+
+(DEFMACRO WITH-STRING
 (STRING
 &REST FORMS)
+
+   (* ;; "WITH-STRING is like WITH-ONE-STRING, but doesn't process keywords")

+
+   `(LET [(SLEN (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
+         ,@FORMS))
+
+(DEFMACRO WITH-TWO-UNPACKED-STRINGS
 (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)
+
+   (* ;; "Used to set up string comparison operations. String1 and string2 are unpacked and start1, end1, start2, end2 are adjusted for non-zero offsets. Base1 and base2, typenumber1, typenumber2 , offset1 and offset2 are bound to the appropriate unpacked quantities")

+
+   `(LET (BASE1 BASE2 OFFSET1 OFFSET2 TYPENUMBER1 TYPENUMBER2)
+         (%%UNPACK-STRING
 ,STRING1 BASE1 OFFSET1 TYPENUMBER1)
+         (%%UNPACK-STRING
 ,STRING2 BASE2 OFFSET2 TYPENUMBER2)
+         (%%ADJUST-FOR-OFFSET
 ,START1 ,END1 OFFSET1)
+         (%%ADJUST-FOR-OFFSET
 ,START2 ,END2 OFFSET2)
+         ,@FORMS))
+
+(DEFMACRO %%UNPACK-STRING
 (OBJECT BASE OFFSET TYPENUMBER &OPTIONAL LENGTH)
+   `[COND
+       [(LISP:SYMBOLP ,OBJECT)
+        (SETQ ,BASE (fetch
 (LITATOM PNAMEBASE) of
 ,OBJECT))
+        (SETQ ,OFFSET 1)
+        (SETQ ,TYPENUMBER (LISP:IF (fetch
 (LITATOM FATPNAMEP) of
 ,OBJECT)
+                              %%FAT-CHAR-TYPENUMBER
+                              %%THIN-CHAR-TYPENUMBER))
+        ,@(LISP:IF LENGTH
+              `[(SETQ ,LENGTH (fetch
 (LITATOM PNAMELENGTH) of
 ,OBJECT])]
+       (T [COND
+             [(%%ONED-ARRAY-P ,OBJECT)
+              (SETQ ,BASE (fetch
 (ARRAY-HEADER BASE) of
 ,OBJECT))
+              (SETQ ,OFFSET (fetch
 (ARRAY-HEADER OFFSET) of
 ,OBJECT))
+              (SETQ ,TYPENUMBER (fetch
 (ARRAY-HEADER TYPE-NUMBER) of
 ,OBJECT]
+             (T (SETQ ,BASE (%%ARRAY-BASE ,OBJECT))
+                (SETQ ,OFFSET (%%ARRAY-OFFSET ,OBJECT))
+                (SETQ ,TYPENUMBER (%%ARRAY-TYPE-NUMBER ,OBJECT]
+          ,@(LISP:IF LENGTH
+                `[(SETQ ,LENGTH (fetch
 (ARRAY-HEADER FILL-POINTER) of
 ,OBJECT])])
+
+(DEFMACRO %%ADJUST-FOR-OFFSET
 (START END OFFSET)
+   `(LISP:WHEN (NOT (EQ 0 ,OFFSET))
+        (SETQ ,START (+ ,START ,OFFSET))
+        (SETQ ,END (+ ,END ,OFFSET))))
+
+(DEFMACRO %%CHECK-BOUNDS
 (START END LENGTH)
+   `[PROGN [COND
+              ((NULL ,END)
+               (SETQ ,END ,LENGTH))
+              ((> ,END ,LENGTH)
+               (LISP:ERROR "End out of bounds: ~S" ,END]
+           (COND
+              ((NULL ,START)
+               (SETQ ,START 0))
+              ((NOT (<= 0 ,START ,END))
+               (LISP:ERROR "Improper substring bounds: ~s ~s" ,START ,END])
+
+(DEFMACRO %%PARSE-STRING-ARGS
 (STRING1 STRING2 START1 END1 START2 END2 &REST FORMS)
+
+   (* ;; "Used to set up string comparison operations. The keywords are defaulted, bounds are checked and  Slen1 and Slen1 are bound to substring lengths%"")

+
+   `(LET [(SLEN1 (%%STRING-LENGTH
 ,STRING1))
+          (SLEN2 (%%STRING-LENGTH
 ,STRING2]
+         (%%CHECK-BOUNDS
 ,START1 ,END1 SLEN1)
+         (%%CHECK-BOUNDS
 ,START2 ,END2 SLEN2)
+         (SETQ SLEN1 (- ,END1 ,START1))
+         (SETQ SLEN2 (- ,END2 ,START2))
+         ,@FORMS))
+
+(DEFMACRO %%STRING-LENGTH
 (STRING
)
+   `(COND
+       ((%%STRINGP ,STRING)
+        (fetch
 (ARRAY-HEADER FILL-POINTER) of
 ,STRING))
+       ((LISP:SYMBOLP ,STRING)
+        (fetch
 (LITATOM PNAMELENGTH) of
 ,STRING))
+       [(LISP:CHARACTERP ,STRING)
+        (VECTOR-LENGTH (SETQ ,STRING (STRING
 ,STRING]
+       (T (LISP:ERROR 'XCL:TYPE-MISMATCH :EXPECTED-TYPE '(OR STRING LISP:SYMBOL LISP:CHARACTER)
+                 :NAME
+                 ,STRING :VALUE ,STRING :MESSAGE "a string, symbol or character"))))
+)
+
+
+
+(* ;; "Compiler options")

+
+
+(PUTPROPS CMLSTRING
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY 
+(DECLARE%: DOEVAL@COMPILE DONTCOPY
+
+(LOCALVARS . T)
+)
+)
+(PUTPROPS CMLSTRING COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CMLTIME

@@ -0,0 +1,280 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
+
(FILECREATED "18-Oct-93 15:20:26" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLTIME.;2"
 15445  
+
+      |previous| |date:| " 3-Sep-91 17:50:39" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLTIME.;1")
+
+
+; Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT CMLTIMECOMS)
+
+(RPAQQ CMLTIMECOMS

+       (
+
+(* |;;;| "Common Lisp Time Functions")

+
+        (FUNCTIONS %CONVERT-INTERNAL-TIME-TO-CLUT)
+        (CONSTANTS (LISP:INTERNAL-TIME-UNITS-PER-SECOND 1000))
+        (FNS LISP:GET-INTERNAL-REAL-TIME LISP:GET-INTERNAL-RUN-TIME LISP:GET-UNIVERSAL-TIME 
+             LISP:GET-DECODED-TIME LISP:DECODE-UNIVERSAL-TIME LISP:ENCODE-UNIVERSAL-TIME LISP:SLEEP)
+        (PROP FILETYPE CMLTIME)
+        (DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA LISP:SLEEP LISP:ENCODE-UNIVERSAL-TIME LISP:DECODE-UNIVERSAL-TIME 
+                            LISP:GET-DECODED-TIME LISP:GET-UNIVERSAL-TIME LISP:GET-INTERNAL-RUN-TIME)
+                      ))))
+
+
+
+(* |;;;| "Common Lisp Time Functions")

+
+
+(DEFMACRO %CONVERT-INTERNAL-TIME-TO-CLUT
 (TIME)
+
+   (* |;;| "Converts from Interlisp-D internal time format to Common Lisp Universal Time")

+
+   `(+ ,TIME (LISP:* 365 24 60 60)
+       MAX.FIXP 1))
+(DECLARE\: EVAL@COMPILE 
+
+(RPAQQ LISP:INTERNAL-TIME-UNITS-PER-SECOND
 1000)
+
+
+(CONSTANTS (LISP:INTERNAL-TIME-UNITS-PER-SECOND 1000))
+)
+(DEFINEQ
+
+(LISP:GET-INTERNAL-REAL-TIME

+  (LAMBDA NIL                                              (* |hdj| "18-Jul-86 12:05")

+
+(* |;;;| "The current time is returned as a single integer in Internal Time format.  (Internal Time format = time in milliseconds for us.) This time is relative to an arbitrary time base, but the difference between the values of two calls to this function will be the amount of elapsed real time between the two calls, measured in the units defined by INTERNAL-TIME-UNITS-PER-SECOND")

+
+    (CLOCK 0)))
+
+(LISP:GET-INTERNAL-RUN-TIME

+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:06")

+
+(* |;;;| "The current run time is returned as a single integer in Internal Time format.  (Internal Time format = time in milliseconds for us.) The precise meaning of this quantity is implementation-dependent;  it may measure real time, run time, CPU cycles, or some other quantity.  The intent is that the difference between the values of two calls to this function be the amount of time between the two calls during which the computational effort was expended on behalf of the executing program.")

+
+         (CLOCK 2)))
+
+(LISP:GET-UNIVERSAL-TIME

+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:02")

+
+(* |;;;| "The current time of day is returned as a single integer in Universal Time format.")

+
+         (%CONVERT-INTERNAL-TIME-TO-CLUT
 (DAYTIME))))
+
+(LISP:GET-DECODED-TIME

+  (LISP:LAMBDA NIL                                         (* |hdj| "18-Jul-86 12:08")

+
+(* |;;;| "The current time is returned in Decoded Time format.  Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.")

+
+         (LISP:DECODE-UNIVERSAL-TIME
 (LISP:GET-UNIVERSAL-TIME
))))
+
+(LISP:DECODE-UNIVERSAL-TIME

+  (LISP:LAMBDA (UNIVERSAL-TIME &OPTIONAL (TIME-ZONE |\\TimeZoneComp| TIME-ZONE-SUPPLIEDP))
+                                                             (* |kbr:| " 7-Aug-86 10:21")

+
+(* |;;;| "The time specified by UNIVERSAL-TIME in Universal Time format is converted to Decoded Time format.  Nine values are returned: SECOND, MINUTE, HOUR, DATE, MONTH, YEAR, DAY-OF-WEEK, DAYLIGHT-SAVING-TIME-P, and TIME-ZONE.")

+
+         (PROG (CHECKDLS TIME MONTH SEC HR TOTALDAYS DAYS LEAP400 LEAP100 LEAP4 YEAR YDAY WDAY MIN 
+                      DLS)
+
+          (* |;;| "Page 446 of the silver book: If you don't specify TIME-ZONE it defaults to the current time zone adjusted for daylight savings time.  If you provide TIME-ZONE explicitly, no adjustment for daylight savings time is is performed.")

+
+               (SETQ CHECKDLS (AND (NOT TIME-ZONE-SUPPLIEDP)
+                                   |\\DayLightSavings|))
+               (LISP:MULTIPLE-VALUE-SETQ (TIME SEC)
+                      (LISP:FLOOR UNIVERSAL-TIME 60))
+               (LISP:MULTIPLE-VALUE-SETQ (TIME MIN)
+                      (LISP:FLOOR TIME 60))
+               (LISP:MULTIPLE-VALUE-SETQ (TOTALDAYS HR)
+                      (LISP:FLOOR (- TIME TIME-ZONE)
+                             24))
+           DTLOOP
+               
+
+          (* |;;| "LEAP400 = number of 400 year blocks till Jan 1, 2000 Note: The algorithm still works correctly for dates after Jan 1, 2000 .  LEAP400 will be negative but not wrong.  (Any Jan 1 a year a multiple of 400 would do nicely.  Jan 1, 2000 just happens to be close by.)")

+
+               (LISP:MULTIPLE-VALUE-SETQ (LEAP400 DAYS)
+                      (LISP:FLOOR (- 36524 TOTALDAYS)
+                             (+ 36525 (LISP:* 3 36524))))    (* \; 
+
                                    "LEAP100 = number of 100 year blocks till the 400 year blocks.")

+               (LISP:MULTIPLE-VALUE-SETQ (LEAP100 DAYS)
+                      (LISP:FLOOR DAYS 36524))               (* \; 
+
                                        "LEAP4 = number of 4 year blocks till the 100 year blocks.")

+               (LISP:MULTIPLE-VALUE-SETQ (LEAP4 DAYS)
+                      (LISP:FLOOR DAYS (+ 366 (LISP:* 3 365))))
+
+          (* |;;| "Date of answer will be (+ (* 146097 LEAP400) (* 36524 LEAP100) (* 1461 LEAP4) DAYS) days before Jan 1, 2000")

+
+               (SETQ YEAR (- 2000 (LISP:* 400 LEAP400)
+                             (LISP:* 100 LEAP100)
+                             (LISP:* 4 LEAP4)
+                             (CDR (\\DTSCAN DAYS '((1096 . 4)
+                                                   (731 . 3)
+                                                   (366 . 2)
+                                                   (1 . 1)
+                                                   (0 . 0))))))
+
+          (* |;;| "YDAY is the ordinal of day as it would appear in a leap year.  We thus have Jan 1 = day 0, Feb 29 = day 59, Mar 1 = day 60, and Dec 31 = day 365.")

+
+               (SETQ YDAY (- (CDR (\\DTSCAN DAYS (COND
+                                                    ((AND (EQ (LISP:MOD YEAR 100)
+                                                              0)
+                                                          (NOT (EQ (LISP:MOD YEAR 400)
+                                                                   0)))
+                                                     '((1402 . 1460)
+                                                       (1096 . 1461)
+                                                       (1037 . 1095)
+                                                       (731 . 1096)
+                                                       (672 . 730)
+                                                       (366 . 731)
+                                                       (307 . 365)
+                                                       (1 . 366)
+                                                       (0 . 0)))
+                                                    (T '((1096 . 1461)
+                                                         (1037 . 1095)
+                                                         (731 . 1096)
+                                                         (672 . 730)
+                                                         (366 . 731)
+                                                         (307 . 365)
+                                                         (1 . 366)
+                                                         (0 . 0))))))
+                             DAYS))
+               (SETQ WDAY (LISP:MOD TOTALDAYS 7))
+               (COND
+                  ((AND CHECKDLS (SETQ DLS (\\ISDST? YDAY HR WDAY)))
+
+                   (* |;;| "This date is during daylight savings, so add 1 hour.  Third arg is day of the week, which we determine by taking days mod 7 plus offset.  Monday = zero in this scheme.  Jan 1 1900 was a Monday=0 so offset is 0")

+
+                   (COND
+                      ((> (SETQ HR (LISP:1+ HR))
+                          23)
+
+                       (* |;;| "overflowed into the next day.  This case is too hard (we might have overflowed the month, for example), so just go back and recompute")

+
+                       (SETQ TOTALDAYS (LISP:1+ TOTALDAYS))
+                       (SETQ HR 0)
+                       (SETQ CHECKDLS NIL)
+                       (GO DTLOOP)))))
+               (SETQ MONTH (\\DTSCAN YDAY '((335 . 12)
+                                            (305 . 11)
+                                            (274 . 10)
+                                            (244 . 9)
+                                            (213 . 8)
+                                            (182 . 7)
+                                            (152 . 6)
+                                            (121 . 5)
+                                            (91 . 4)
+                                            (60 . 3)
+                                            (31 . 2)
+                                            (0 . 1))))       (* \; 
+
                             "Now return (SECOND MINUTE HOUR DAY MONTH YEAR WEEKDAY DAYLIGHT ZONE)")

+               (RETURN (LISP:VALUES SEC MIN HR (LISP:1+ (- YDAY (CAR MONTH)))
+                              (CDR MONTH)
+                              YEAR WDAY DLS TIME-ZONE)))))
+
+(LISP:ENCODE-UNIVERSAL-TIME

+  (LISP:LAMBDA (SECOND MINUTE HOUR DATE MONTH YEAR &OPTIONAL TIME-ZONE)
+                                                             (* \; "Edited 27-Oct-87 19:11 by bvm:")

+
+(* |;;;| "The time specified by the given components of Decoded Time format is encoded into Universal Time format and returned.  If you don't specify TIME-ZONE, it defaults to the current time zone adjusted for daylight saving time.  If you provide TIME-ZONE explicitly, no adjustment for daylight saving time is performed.")

+
+         (PROG (YDAY DAYSSINCEDAY0)
+
+          (* |;;| "From pages 444 and 445 of the silver book and Lucid testing, here are three examples of ENCODE-UNIVERSAL-TIME usage known to be correct and which should be rechecked by anyone who edits this function: (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1900 0) = 1 (ENCODE-UNIVERSAL-TIME 1 0 0 1 1 1976 0) = 2398291201 (ENCODE-UNIVERSAL-TIME 0 0 0 1 1 3000 0) = 34712668800")

+
+          (* |;;| 
+
        "If the YEAR is between 0 and 99 we have to figure out what the `obvious' year is.")

+
+               (SETQ YEAR (LISP:IF (< YEAR 100)
+                              (LISP:MULTIPLE-VALUE-BIND
+                               (SEC MIN HOUR DAY MONTH NOW-YEAR)
+                               (LISP:GET-DECODED-TIME
)
+                               (DECLARE
 (IGNORE SEC MIN HOUR DAY MONTH))
+                               (LISP:DO ((Y (+ YEAR (LISP:* 100 (LISP:1- (LISP:TRUNCATE NOW-YEAR 100)
+                                                                       )))
+                                            (+ Y 100)))
+                                        ((<= (ABS (- Y NOW-YEAR))
+                                             50)
+                                         Y)))
+                              YEAR))
+               (SETQ YDAY (+ (SELECTQ MONTH
+                                 (1 0)
+                                 (2 31)
+                                 (3 59)
+                                 (4 90)
+                                 (5 120)
+                                 (6 151)
+                                 (7 181)
+                                 (8 212)
+                                 (9 243)
+                                 (10 273)
+                                 (11 304)
+                                 (12 334)
+                                 NIL)
+                             (SUB1 DATE)))
+               (SETQ DAYSSINCEDAY0 (+ YDAY (TIMES 365 (SETQ YEAR (IDIFFERENCE YEAR 1900)))
+                                      (IQUOTIENT (SUB1 YEAR)
+                                             4)))
+               (|if|
 (> MONTH 2)
+                   |then|
                                (* \; "After February 28")

+                         (|add|
 YDAY 1)                  (* \; 
+
                                                           "Day-of-year is based on 366-day year")

+                         (|if|
 (AND (EQ 0 (IREMAINDER YEAR 4))
+                                        (OR (NOT (EQ (IREMAINDER YEAR 100)
+                                                     0))
+                                            (EQ (IREMAINDER YEAR 400)
+                                                0)))
+                             |then|
                      (* \; 
+
                                            "It is a leap year, so real day count also incremented")

+                                   (|add|
 DAYSSINCEDAY0 1)))
+
+          (* |;;| "This is almost right - now correct for 100/400 leap year rule. 1900 is magically handled by above formula, and 2000 is a leap year, so we only need to do this for years after 2100.")

+
+               (FOR
 I FROM
 200 TO
 YEAR BY
 100
+                  UNLESS
 (OR (= I YEAR)
+                                 (EQ (IREMAINDER I 400)
+                                     100)) DO
 (LISP:DECF DAYSSINCEDAY0))
+               (SETQ HOUR (+ HOUR (TIMES 24 DAYSSINCEDAY0)
+                             (COND
+                                (TIME-ZONE TIME-ZONE)
+                                ((AND |\\DayLightSavings| (\\ISDST? YDAY HOUR (IREMAINDER 
+                                                                                     DAYSSINCEDAY0 7)
+                                                                 ))
+
+                                 (* |;;| "Subtract one to go from daylight to standard time.  Weekday argument (IREMAINDER DAYSSINCEDAY0 7) to \\ISDST?  is based on day 0 = Jan 1, 1900, which was a Monday = 0")

+
+                                 (SUB1 |\\TimeZoneComp|))
+                                (T |\\TimeZoneComp|))))
+               (RETURN (+ SECOND (TIMES 60 (+ MINUTE (TIMES 60 HOUR))))))))
+
+(LISP:SLEEP

+  (LISP:LAMBDA (LISP::SECONDS)                               (* \; "Edited 24-Apr-87 15:28 by jrb:")

+
+(* |;;;| "(SLEEP N) causes execution to cease and become dormant for approximately N seconds of real time, whereupon execution is resumed.  The argument may be any non-negative non-complex number.  SLEEP returns NIL.")

+
+         (DISMISS (ROUND (LISP:* LISP::SECONDS 1000)))
+         NIL))
+)
+
+(PUTPROPS CMLTIME
 FILETYPE
 LISP:COMPILE-FILE)
+(DECLARE\: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 LISP:SLEEP LISP:ENCODE-UNIVERSAL-TIME LISP:DECODE-UNIVERSAL-TIME 
+                         LISP:GET-DECODED-TIME LISP:GET-UNIVERSAL-TIME LISP:GET-INTERNAL-RUN-TIME)
+)
+(PUTPROPS CMLTIME COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL (1558 14987 (LISP:GET-INTERNAL-REAL-TIME 1568 . 2100) (LISP:GET-INTERNAL-RUN-TIME 2102
+ . 2752) (LISP:GET-UNIVERSAL-TIME 2754 . 3033) (LISP:GET-DECODED-TIME 3035 . 3419) (
+LISP:DECODE-UNIVERSAL-TIME 3421 . 9799) (LISP:ENCODE-UNIVERSAL-TIME 9801 . 14566) (LISP:SLEEP 14568 . 
+14985)))))
+STOP

CLTL2/CMLTYPES

@@ -0,0 +1,376 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
+
(IL:FILECREATED " 8-Feb-93 16:55:40" IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;9|
 46967  
+
+      IL:|changes| IL:|to:|  (IL:TYPES ARRAY SIMPLE-ARRAY)
+
+      IL:|previous| IL:|date:| " 1-Apr-92 12:17:57" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CMLTYPES.;8|)
+
+
+; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLTYPESCOMS)
+
+(IL:RPAQQ IL:CMLTYPESCOMS ((IL:* IL:|;;;| "Implementation of Common Lisp type system.  ") (IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.") (IL:* IL:|;;;| "Predicates") (IL:FUNCTIONS COMMONP) (IL:* IL:|;;;| "Typep and friends") (IL:VARIABLES *TYPEP-HASH-TABLE*) (IL:FUNCTIONS TYPEP TYPE-OF COERCE TYPECASE) (IL:FUNCTIONS %VALID-TYPE-P) (XCL:OPTIMIZERS TYPEP COERCE) (IL:* IL:|;;;| "for DEFTYPE") (IL:DEFINE-TYPES IL:TYPES) (IL:FUNCTIONS DEFTYPE TYPE-EXPAND TYPE-EXPANDER SETF-TYPE-EXPANDER) (IL:SETFS TYPE-EXPANDER) (IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD (IL:* IL:|;;| "There is still code out there that calls the IL: versions") (IL:P (IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND)) (IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER)))) (IL:* IL:|;;;| "Support functions") (IL:FUNCTIONS ARRAY-TYPE SYMBOL-TYPE XCL:FALSE XCL:TRUE %RANGE-TYPE) (IL:FUNCTIONS NUMBERP FLOATP CL:REALP) (XCL:OPTIMIZERS NUMBERP FLOATP CL:REALP XCL:FALSE XCL:TRUE) (IL:* IL:|;;;| "For TYPEP") (IL:FUNCTIONS %TYPEP-PRED BIGNUMP) (IL:* IL:|;;;| "for SUBTYPEP ") (IL:VARIABLES %NO-SUPER-TYPE *COMMON-LISP-BASE-TYPES* *BASE-TYPE-LATTICE*) (IL:FUNCTIONS SUBTYPEP SUBTYPEP-TYPE-EXPAND SI::DATATYPE-P SI::SUB-DATATYPE-P EQUAL-DIMENSIONS COMPLETE-ARRAY-TYPE-DIMENSIONS COMPLETE-META-EXPRESSION-DEFAULTS RANGE<= BASE-SUBTYPEP EQUAL-ELEMENT-TYPE USEFUL-TYPE-EXPANSION-P) (IL:* IL:|;;;| "Basic deftypes") (IL:TYPES ATOM BIGNUM BIT CHARACTER CONS DOUBLE-FLOAT EQL FIXNUM STREAM FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD LIST LONG-FLOAT MEMBER MOD NULL NUMBER PACKAGE CL:REAL SHORT-FLOAT SIGNED-BYTE STANDARD-CHAR STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER SINGLE-FLOAT SYMBOL UNSIGNED-BYTE RATIONAL READTABLE COMMON COMPILED-FUNCTION SEQUENCE) (IL:* IL:|;;;| "Array Types") (IL:TYPES ARRAY VECTOR STRING SIMPLE-STRING SIMPLE-ARRAY SIMPLE-VECTOR BIT-VECTOR SIMPLE-BIT-VECTOR CL:BASE-STRING CL:SIMPLE-BASE-STRING) (IL:* IL:|;;;| "Stream types required by CLtL2") (IL:TYPES CL:BROADCAST-STREAM CL:CONCATENATED-STREAM CL:ECHO-STREAM CL:SYNONYM-STREAM CL:STRING-STREAM CL:FILE-STREAM CL:TWO-WAY-STREAM) (IL:* IL:|;;;| "Fast predicates for typep") (IL:DEFINE-TYPES TYPEP) (IL:FUNCTIONS DEFTYPEP) (TYPEP LIST SEQUENCE MEMBER ARRAY SIMPLE-ARRAY VECTOR SIMPLE-VECTOR COMPLEX INTEGER MOD SIGNED-BYTE UNSIGNED-BYTE RATIONAL FLOAT STRING SIMPLE-STRING BIT-VECTOR SIMPLE-BIT-VECTOR EQL CL:REAL) (IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names") (IL:PROP CMLTYPE IL:CHARACTER IL:FIXP IL:FLOATP IL:GENERAL-ARRAY IL:LISTP IL:LITATOM IL:ONED-ARRAY IL:SMALLP IL:HARRAYP IL:TWOD-ARRAY) (IL:PROP CMLSUBTYPE-DESCRIMINATOR SYMBOL ARRAY) (IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property") (IL:PROP IL:PROPTYPE :TYPE-EXPANDER IL:TYPE-EXPANDER) (IL:* IL:|;;;| "Compiler options") (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CMLTYPES) (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T))))
+
+
+
+(IL:* IL:|;;;| "Implementation of Common Lisp type system.  ")

+
+
+
+
+(IL:* IL:|;;;| "implementation by Greg Nuyens ,Larry Masinter and Jan Pedersen.")

+
+
+
+
+(IL:* IL:|;;;| "Predicates")

+
+
+(DEFUN COMMONP (OBJECT) (TYPEP OBJECT (QUOTE COMMON)))
+
+
+
+(IL:* IL:|;;;| "Typep and friends")

+
+
+(DEFPARAMETER *TYPEP-HASH-TABLE* (MAKE-HASH-TABLE :TEST (QUOTE EQ)))
+
+(DEFUN TYPEP (OBJECT TYPE) (IL:* IL:|;;| "Check if OBJECT is of type TYPE") (LET* ((SYMBOL-TYPE (IF (CONSP TYPE) (CAR TYPE) TYPE)) (FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*))) (IF FN (IF (CONSP TYPE) (FUNCALL FN OBJECT (CDR TYPE)) (FUNCALL FN OBJECT)) (IL:* IL:|;;| "Expand the type") (IF (CONSP TYPE) (CASE SYMBOL-TYPE (SATISFIES (FUNCALL (CADR TYPE) OBJECT)) ((:DATATYPE IL:DATATYPE) (IL:TYPENAMEP OBJECT (CADR TYPE))) (NOT (NOT (TYPEP OBJECT (CADR TYPE)))) (AND (DOLIST (SUB-TYPE (CDR TYPE) T) (IF (NOT (TYPEP OBJECT SUB-TYPE)) (RETURN NIL)))) (OR (DOLIST (SUB-TYPE (CDR TYPE) NIL) (IF (TYPEP OBJECT SUB-TYPE) (RETURN T)))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER TYPE)) (ERROR "Unknown type expression: ~s" TYPE))))) (CASE SYMBOL-TYPE ((T) T) ((NIL) NIL) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER SYMBOL-TYPE))) (IF EXPANDER (TYPEP OBJECT (FUNCALL EXPANDER (LIST TYPE))) (ERROR "Unknown type expression: ~s" TYPE)))))))))
+
+(DEFUN TYPE-OF (X) (LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X)))))) (SETQ TYPENAME (OR (GET TYPENAME (QUOTE CMLTYPE)) TYPENAME)) (OR (LET ((D (GET TYPENAME (QUOTE CMLSUBTYPE-DESCRIMINATOR)))) (AND D (FUNCALL D X))) TYPENAME)))
+
+(DEFUN COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Coerce object to result-type if possible") (IF (TYPEP OBJECT RESULT-TYPE) OBJECT (COND ((EQ RESULT-TYPE (QUOTE CHARACTER)) (CHARACTER OBJECT)) ((MEMBER RESULT-TYPE (QUOTE (FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT)) :TEST (FUNCTION EQ)) (FLOAT OBJECT)) ((EQ (IF (CONSP RESULT-TYPE) (CAR RESULT-TYPE) RESULT-TYPE) (QUOTE COMPLEX)) (IF (CONSP RESULT-TYPE) (LET ((SUBTYPE (CADR RESULT-TYPE))) (IF (COMPLEXP OBJECT) (COMPLEX (COERCE (REALPART OBJECT) SUBTYPE) (COERCE (IMAGPART OBJECT) SUBTYPE)) (COMPLEX (COERCE OBJECT SUBTYPE)))) (COMPLEX OBJECT))) ((TYPEP OBJECT (QUOTE SEQUENCE)) (MAP RESULT-TYPE (QUOTE IDENTITY) OBJECT)) (T (ERROR "Cannot coerce ~S to type: ~S" OBJECT RESULT-TYPE)))))
+
+(DEFMACRO TYPECASE (KEYFORM &REST FORMS) "Type dispatch, order is important, more specific types should appear first" (IL:BQUOTE (LET (($$TYPE-VALUE (IL:\\\, KEYFORM))) (COND (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (FORM) (LET ((PRED (IF (MEMBER (CAR FORM) (QUOTE (OTHERWISE T)) :TEST (FUNCTION EQ)) T (IL:BQUOTE (TYPEP $$TYPE-VALUE (QUOTE (IL:\\\, (CAR FORM))))))) (FORM (IF (NULL (CDR FORM)) (QUOTE (NIL)) (CDR FORM)))) (IL:BQUOTE ((IL:\\\, PRED) (IL:\\\,@ FORM)))))) FORMS))))))
+
+(DEFUN %VALID-TYPE-P (TYPE) (IF (CONSP TYPE) (CASE (CAR TYPE) (SATISFIES T) ((OR AND) (EVERY (QUOTE %VALID-TYPE-P) (CDR TYPE))) (NOT (%VALID-TYPE-P (CADR TYPE))) ((:DATATYPE IL:DATATYPE) T) (OTHERWISE (AND (TYPE-EXPANDER TYPE) T))) (OR (AND (TYPE-EXPANDER TYPE) T) (EQ TYPE T) (NULL TYPE))))
+
+(XCL:DEFOPTIMIZER TYPEP (OBJ TYPE) (IF (CONSTANTP TYPE) (LET ((TYPE-EXPR (EVAL TYPE))) (IF (%VALID-TYPE-P TYPE-EXPR) (IL:BQUOTE ((IL:\\\, (%TYPEP-PRED TYPE-EXPR)) (IL:\\\, OBJ))) (PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ TYPE) (QUOTE COMPILER:PASS)))) (QUOTE COMPILER:PASS)))
+
+(XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE) (IL:* IL:|;;| "Open code the simple coerce cases ") (IF (CONSTANTP RESULT-TYPE) (CASE (EVAL RESULT-TYPE) (CHARACTER (IL:BQUOTE (CHARACTER (IL:\\\, OBJECT)))) ((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT) (IL:BQUOTE (FLOAT (IL:\\\, OBJECT)))) (OTHERWISE (QUOTE COMPILER:PASS))) (QUOTE COMPILER:PASS)))
+
+
+
+(IL:* IL:|;;;| "for DEFTYPE")

+
+
+(XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions")
+
+(XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME) (AND (SYMBOLP NAME) (IL:BQUOTE (DEFTYPE (IL:\\\, NAME) ("Arg list") "Body")))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY BODY) (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPE: ~S" NAME)) (LET ((EXPANDER-NAME (XCL:PACK (LIST "type-expand-" NAME) (SYMBOL-PACKAGE NAME)))) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO DEFTYPE-ARGS (QUOTE SI::%$$TYPE-FORM) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *))) (IL:BQUOTE (EVAL-WHEN (EVAL COMPILE LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, EXPANDER-NAME))) (FUNCTION (LAMBDA (SI::%$$TYPE-FORM) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (IL:\\\, PARSED-BODY))))) (SETF (TYPE-EXPANDER (QUOTE (IL:\\\, NAME))) (QUOTE (IL:\\\, EXPANDER-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPE)) (IL:\\\, DOCSTRING)))))) (IL:\\\,@ (IF (NULL DEFTYPE-ARGS) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:BQUOTE ((EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT) (TYPEP SI::%$$OBJECT (QUOTE (IL:\\\, NAME)))))) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* (QUOTE (IL:\\\, TYPEP-NAME)))) (EVAL-WHEN (EVAL) (PUTHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE* NIL))))))))))))
+
+(DEFUN TYPE-EXPAND (FORM &OPTIONAL (EXPANDER (TYPE-EXPANDER FORM))) (IL:* IL:|;;| "Expands a type form according to deftypes in effect.  The caller must ensure there is an expander for the form ") (IF EXPANDER (VALUES (FUNCALL EXPANDER (ETYPECASE FORM (SYMBOL (LIST FORM)) (CONS FORM))) T) (VALUES FORM NIL)))
+
+(DEFUN TYPE-EXPANDER (TYPE) (LET* ((SYMBOL-TYPE (ETYPECASE TYPE (SYMBOL TYPE) (CONS (CAR TYPE)))) (EXPANDER (OR (GET SYMBOL-TYPE (QUOTE :TYPE-EXPANDER)) (GET SYMBOL-TYPE (QUOTE IL:TYPE-EXPANDER))))) (IF (AND (NULL EXPANDER) (SYMBOLP TYPE) (SI::DATATYPE-P TYPE)) (IL:* IL:|;;| "Install a deftype") (LET ((DEFTYPE-FORM (IL:BQUOTE (DEFTYPE (IL:\\\, TYPE) NIL (QUOTE (:DATATYPE (IL:\\\, TYPE))))))) (IF (FBOUNDP (QUOTE XCL:COMPILE-FORM)) (IL:* IL:|;;| "Compile form on the fly") (XCL:COMPILE-FORM DEFTYPE-FORM) (LET ((IL:DFNFLG NIL) (IL:FILEPKGFLG NIL) (IL:* IL:|;;| "DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.")) (EVAL DEFTYPE-FORM))) (TYPE-EXPANDER TYPE)) EXPANDER)))
+
+(DEFMACRO SETF-TYPE-EXPANDER (SYMBOL EXPANDER) (IL:BQUOTE (SETF (GET (IL:\\\, SYMBOL) (QUOTE :TYPE-EXPANDER)) (IL:\\\, EXPANDER))))
+
+(DEFSETF TYPE-EXPANDER SETF-TYPE-EXPANDER)
+(IL:DECLARE\: IL:DOCOPY IL:DONTEVAL@LOAD 
+
+(IL:MOVD (QUOTE TYPE-EXPAND) (QUOTE IL:TYPE-EXPAND))
+
+(IL:MOVD (QUOTE TYPE-EXPANDER) (QUOTE IL:TYPE-EXPANDER))
+)
+
+
+
+(IL:* IL:|;;;| "Support functions")

+
+
+(DEFUN ARRAY-TYPE (ARRAY) (LET ((RANK (ARRAY-RANK ARRAY))) (IF (XCL:SIMPLE-ARRAY-P ARRAY) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((SIMPLE-STRING-P ARRAY) (LIST (QUOTE SIMPLE-STRING) SIZE)) ((SIMPLE-BIT-VECTOR-P ARRAY) (LIST (QUOTE SIMPLE-BIT-VECTOR) SIZE)) (T (LET ((ELT-TYPE (ARRAY-ELEMENT-TYPE ARRAY))) (IF (EQ ELT-TYPE T) (LIST (QUOTE SIMPLE-VECTOR) SIZE) (LIST (QUOTE SIMPLE-ARRAY) ELT-TYPE (LIST SIZE))))))) (LIST (QUOTE SIMPLE-ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))) (IF (EQ 1 RANK) (LET ((SIZE (ARRAY-TOTAL-SIZE ARRAY))) (COND ((STRINGP ARRAY) (LIST (QUOTE STRING) SIZE)) ((BIT-VECTOR-P ARRAY) (LIST (QUOTE BIT-VECTOR) SIZE)) (T (LIST (QUOTE VECTOR) (ARRAY-ELEMENT-TYPE ARRAY) SIZE)))) (LIST (QUOTE ARRAY) (ARRAY-ELEMENT-TYPE ARRAY) (ARRAY-DIMENSIONS ARRAY))))))
+
+(DEFUN SYMBOL-TYPE (SYMBOL) (IF (KEYWORDP SYMBOL) (QUOTE KEYWORD) (QUOTE SYMBOL)))
+
+(DEFUN XCL:FALSE NIL NIL)
+
+(DEFUN XCL:TRUE NIL T)
+
+(DEFUN %RANGE-TYPE (BASE-TYPE LOW HIGH RANGE-LIST) (IL:* IL:|;;| "Returns a type form discriminating basetype.  Rangelist is a list of (decreasing) subranges of the full range of basetype (represented as a list of low, high and subtype).  If low and high fall within its range, a form is returned which discriminates on the subtype, and checks the range.  If low and high are exactly the range of the subtype then no range checking form is returned.") (COND ((AND (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) BASE-TYPE) ((OR (EQ LOW (QUOTE *)) (EQ HIGH (QUOTE *))) (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (IL:\\\,@ (IF (NOT (EQ LOW (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X))))) (IL:\\\,@ (IF (NOT (EQ HIGH (QUOTE *))) (IL:BQUOTE (((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH))))))))))) (T (DOLIST (X RANGE-LIST (IL:BQUOTE (AND (IL:\\\, BASE-TYPE) (SATISFIES (LAMBDA (X) (AND ((IL:\\\, (COND ((CONSP LOW) (SETQ LOW (CAR LOW)) (QUOTE <)) (T (QUOTE <=)))) (IL:\\\, LOW) X) ((IL:\\\, (COND ((CONSP HIGH) (SETQ HIGH (CAR HIGH)) (QUOTE <)) (T (QUOTE <=)))) X (IL:\\\, HIGH)))))))) (IL:* IL:|;;| "If the limits are exactly the range specified in the rangelist, then return the corresponding type (since no range-check will be required in the result).") (IF (AND (EQUAL LOW (CAR X)) (EQUAL HIGH (CADR X))) (RETURN (CADDR X))) (IL:* IL:|;;| "If the limits are within the range, then remember the basetype.") (IF (<= (CAR X) (IF (CONSP LOW) (1+ (CAR LOW)) LOW) (IF (CONSP HIGH) (1- (CAR HIGH)) HIGH) (CADR X)) (SETQ BASE-TYPE (CADDR X)))))))
+
+(DEFUN NUMBERP (X) (AND (IL:NUMBERP X) T))
+
+(DEFUN FLOATP (X) (AND (IL:FLOATP X) T))
+
+(DEFUN CL:REALP (CL::X) (TYPEP CL::X (QUOTE CL:REAL)))
+
+(XCL:DEFOPTIMIZER NUMBERP (X) (IL:BQUOTE (AND (IL:NUMBERP (IL:\\\, X)) T)))
+
+(XCL:DEFOPTIMIZER FLOATP (X) (IL:BQUOTE (AND (IL:FLOATP (IL:\\\, X)) T)))
+
+(XCL:DEFOPTIMIZER CL:REALP (CL::X) (IL:BQUOTE (TYPEP (IL:\\\, CL::X) (QUOTE CL:REAL))))
+
+(XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS) (IL:BQUOTE (PROG1 NIL (IL:\\\,@ IL:FORMS))))
+
+(XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS) (IL:BQUOTE (PROG1 T (IL:\\\,@ XCL::FORMS))))
+
+
+
+(IL:* IL:|;;;| "For TYPEP")

+
+
+(DEFUN %TYPEP-PRED (TYPE) (IL:* IL:|;;| "returns the predicate of one argument that determines this type.") (COND ((CONSP TYPE) (CASE (CAR TYPE) (SATISFIES (CADR TYPE)) ((:DATATYPE IL:DATATYPE) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) (IL:TYPENAMEP SI::%$$OBJECT (QUOTE (IL:\\\, (CADR TYPE))))))) ((AND OR NOT) (IL:BQUOTE (LAMBDA (SI::%$$OBJECT) ((IL:\\\, (CAR TYPE)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SUBTYPE) (LIST (%TYPEP-PRED SUBTYPE) (QUOTE SI::%$$OBJECT)))) (CDR TYPE))))))) (OTHERWISE (LET ((EXPANDER (TYPE-EXPANDER (CAR TYPE)))) (IF EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER TYPE)) (CERROR "Look again for a deftype on ~S." "No type definition for ~S. Specify one with DEFTYPE." TYPE)))))) (T (COND ((EQ TYPE T) (QUOTE XCL:TRUE)) ((EQ TYPE NIL) (QUOTE XCL:FALSE)) (T (LET ((EXPANDER (TYPE-EXPANDER TYPE))) (COND (EXPANDER (%TYPEP-PRED (FUNCALL EXPANDER (LIST TYPE)))) (T (IL:* IL:|;;| "there is no deftype on this  non-list type. ") (LOOP (IF (TYPE-EXPANDER TYPE) (RETURN NIL)) (CERROR "Use the deftype you have specified." "No type definition for ~S. Specify one with DEFTYPE." TYPE)) (%TYPEP-PRED TYPE)))))))))
+
+(DEFUN BIGNUMP (X) (OR (IL:TYPENAMEP X (QUOTE IL:FIXP)) (IL:TYPENAMEP X (QUOTE BIGNUM))))
+
+
+
+(IL:* IL:|;;;| "for SUBTYPEP ")

+
+
+(DEFCONSTANT %NO-SUPER-TYPE 0 "the value in the dtdsupertype field which indicates no super type.")
+
+(DEFCONSTANT *COMMON-LISP-BASE-TYPES* (IL:* IL:|;;| "The types which are known to be disjoint from any type explicitly handled by subtypep.") (QUOTE ((IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.") ARRAY ATOM CL:BASE-CHARACTER BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.") CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE (IL:* IL:\; "this is only here for back-compatibility.  The first global recompile, this can go.") :DATATYPE CL:EXTENDED-CHARACTER FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME RANDOM-STATE RATIO (IL:* IL:\; "same comment for ratio as bignum.") RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T)))
+
+(DEFCONSTANT *BASE-TYPE-LATTICE* (QUOTE ((NUMBER CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM COMPLEX FLOAT) (CL:REAL RATIONAL INTEGER RATIO FIXNUM BIGNUM FLOAT) (RATIONAL INTEGER RATIO FIXNUM BIGNUM) (INTEGER FIXNUM BIGNUM) (CHARACTER STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (STRING-CHAR CL:BASE-CHARACTER CL:EXTENDED-CHARACTER STANDARD-CHAR) (CL:EXTENDED-CHARACTER CL:BASE-CHARACTER STANDARD-CHAR) (CL:BASE-CHARACTER STANDARD-CHAR) (LIST NULL) (SYMBOL KEYWORD NULL) (ARRAY SIMPLE-ARRAY) (FUNCTION COMPILED-FUNCTION) (NIL) (IL:DATATYPE :DATATYPE) (IL:* IL:\; "the presence of il:datatype is for back compatibility.") (:DATATYPE IL:DATATYPE))) "the lattice which tells the (base) subtypes of any base type.")
+
+(DEFUN SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type1 is a subtype of type2.  If second value is nil, couldn't decide.") (IF (EQUAL TYPE1 TYPE2) (IL:* IL:|;;| "no need to complete any further recursion, so just return success.") (VALUES T T) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) (AND (IL:* IL:|;;| "(subtypep '(and t1 t2 ...) 't3) <= (or (subtypep 't1 't3) (subtypep 't2 't3) ...  ) because '(and t1 t2 ...) denotes the intersection of types t1, t2, ...") (IL:* IL:|;;| "Even if none of the conjuncts is a subtype, we still can't return (NIL T) because the intersection might still be a subtype.") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE1-CONJUNCT (CDR TYPE1) LOOP-CERTAINTY) (IL:* IL:|;;| "returns t only if every conjunct clause is a certain subtype, or if one conjunct clause is certainly not a subtype") (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1-CONJUNCT TYPE2)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "Try to expand type1") (MULTIPLE-VALUE-BIND (NEW-TYPE1 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE1) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE1 EXPANDED?) (SUBTYPEP NEW-TYPE1 TYPE2) (IL:* IL:|;;| "We now have a base type for type1, there is nothing further to be done with it, by itself.  So we check for special cases in type2") (CASE (IF (CONSP TYPE2) (CAR TYPE2) TYPE2) (AND (IL:* IL:|;;| " (subtypep 't1 '(and t2 t3 ...)) <=> (and (subtypep 't1 't2) (subtypep 't1 't3) ...) because '(and t2 t3 ...) denotes the intersection of types t2, t3, ...") (LET ((RESULT T) CERTAINTY (LOOP-CERTAINTY T) CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) LOOP-CERTAINTY) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (COND ((NULL CONJUNCT-RESULT) (SETQ RESULT NIL) (IF CONJUNCT-CERTAINTY (RETURN T) (IL:* IL:|;;| "else continue to look for a more cetain result") (SETQ LOOP-CERTAINTY NIL))) (T (IF (NULL CONJUNCT-CERTAINTY) (SETQ LOOP-CERTAINTY NIL)))))) (VALUES RESULT CERTAINTY))) (OR (IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ...  ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...") (IL:* IL:|;;| "We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.") (IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))") (IL:* IL:|;;| "(deftype oddp nil '(and integer (satisfies %oddp)))") (IL:* IL:|;;| "(subtypep 'integer '(or evenp oddp)) is true, but the satisfies makes it undecidable, so we must return (nil nil).") (LET ((RESULT NIL) CERTAINTY CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SETQ CERTAINTY (DOLIST (TYPE2-CONJUNCT (CDR TYPE2) NIL) (MULTIPLE-VALUE-SETQ (CONJUNCT-RESULT CONJUNCT-CERTAINTY) (SUBTYPEP TYPE1 TYPE2-CONJUNCT)) (WHEN CONJUNCT-RESULT (SETQ RESULT T) (IF CONJUNCT-CERTAINTY (RETURN T))))) (VALUES RESULT CERTAINTY))) (OTHERWISE (IL:* IL:|;;| "try to expand type2.") (MULTIPLE-VALUE-BIND (NEW-TYPE2 EXPANDED?) (SUBTYPEP-TYPE-EXPAND TYPE2) (IF (USEFUL-TYPE-EXPANSION-P NEW-TYPE2 EXPANDED?) (SUBTYPEP TYPE1 NEW-TYPE2) (IL:* IL:|;;| "we have now handled everything but base types.  There is no further expansion etc, to be done.") (BASE-SUBTYPEP TYPE1 TYPE2)))))))))))
+
+(DEFUN SUBTYPEP-TYPE-EXPAND (TYPE) (IL:* IL:|;;| "Like type-expand, except it doesn't expand base-types.") (IF (MEMBER (IF (CONSP TYPE) (CAR TYPE) TYPE) *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (VALUES TYPE NIL) (TYPE-EXPAND TYPE)))
+
+(DEFUN SI::DATATYPE-P (SI::NAME) (IL:* IL:|;;| "Returns T if name is a datatype known to the XAIE type system") (AND (IL:\\TYPENUMBERFROMNAME SI::NAME) T))
+
+(DEFUN SI::SUB-DATATYPE-P (TYPE1 TYPE2) (IL:* IL:|;;| "Returns T if type2 is a (not necessarily proper) supertype of type1.") (DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1)) (TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2)) (SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD SUPER-TYPE-NUMBER)))) ((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER) (IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL  ") NIL) (IF (EQ SUPER-TYPE-NUMBER TYPE-NUMBER-2) (RETURN T))))
+
+(DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2) (IL:* IL:|;;| "Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).") (OR (EQ DIMS1 (QUOTE *)) (EQ DIMS2 (QUOTE *)) (AND (EQUAL (LENGTH DIMS1) (LENGTH DIMS2)) (DO ((DIM1 DIMS1 (CDR DIM1)) (DIM2 DIMS2 (CDR DIM2))) ((NULL DIM1) T) (IF (NOT (OR (EQ (CAR DIM1) (QUOTE *)) (EQ (CAR DIM2) (QUOTE *)) (EQ (CAR DIM1) (CAR DIM2)))) (RETURN NIL))))))
+
+(DEFUN COMPLETE-ARRAY-TYPE-DIMENSIONS (DIMENSIONS) (ETYPECASE DIMENSIONS (CONS DIMENSIONS) ((OR NULL (MEMBER *)) (QUOTE *)) (INTEGER (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))))
+
+(DEFUN COMPLETE-META-EXPRESSION-DEFAULTS (TYPE) (IL:* IL:|;;| "given a type expression finishes the defaults the same way as the type-expander.") (LET ((LIST-TYPE (IF (LISTP TYPE) TYPE (LIST TYPE)))) (CASE (CAR LIST-TYPE) ((SIMPLE-ARRAY ARRAY) (CL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *)) (DIMENSIONS (QUOTE *))) LIST-TYPE (LIST ARRAY-TYPE ELEMENT-TYPE (COMPLETE-ARRAY-TYPE-DIMENSIONS DIMENSIONS)))) ((INTEGER FLOAT RATIONAL) (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (LOWER (QUOTE *)) (HIGHER (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE LOWER HIGHER))) (COMPLEX (CL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL (ELEMENT-TYPE (QUOTE *))) LIST-TYPE (LIST NUMERIC-TYPE ELEMENT-TYPE))) (T TYPE))))
+
+(DEFUN RANGE<= (LOW2 LOW1 HIGH1 HIGH2 TYPE1 TYPE2) (IL:* IL:|;;;| "Returns t if bound1 is less than or equal bound2, allowing for wildcards. ") (IF (EQ TYPE1 (QUOTE INTEGER)) (COND ((CONSP LOW1) (SETQ LOW1 (+ (CAR LOW1) 1))) ((CONSP HIGH1) (SETQ HIGH1 (- (CAR HIGH1) 1))))) (IF (EQ TYPE2 (QUOTE INTEGER)) (COND ((CONSP LOW2) (SETQ LOW2 (+ (CAR LOW2) 1))) ((CONSP HIGH2) (SETQ HIGH2 (- (CAR HIGH2) 1))))) (AND (IL:* IL:|;;| "check the low bounds") (COND ((EQ LOW2 (QUOTE *)) T) ((EQ LOW1 (QUOTE *)) NIL) (T (IF (CONSP LOW2) (IF (CONSP LOW1) (<= (CAR LOW2) (CAR LOW1)) (< (CAR LOW2) LOW1)) (IF (CONSP LOW1) (<= LOW2 (CAR LOW1)) (<= LOW2 LOW1))))) (IL:* IL:|;;| "Check the high bounds") (COND ((EQ HIGH2 (QUOTE *)) T) ((EQ HIGH1 (QUOTE *)) NIL) (T (IF (CONSP HIGH2) (IF (CONSP HIGH1) (>= (CAR HIGH2) (CAR HIGH1)) (> (CAR HIGH2) HIGH1)) (IF (CONSP HIGH1) (>= HIGH2 (CAR HIGH1)) (>= HIGH2 HIGH1)))))))
+
+(DEFUN BASE-SUBTYPEP (TYPE1 TYPE2) (IL:* IL:|;;| "Contains subtypep's special cases for base types.") (LET ((SYMBOL-TYPE1 (IF (CONSP TYPE1) (CAR TYPE1) TYPE1)) (SYMBOL-TYPE2 (IF (CONSP TYPE2) (CAR TYPE2) TYPE2))) (COND ((OR (EQ TYPE1 NIL) (EQ TYPE2 T) (EQUAL TYPE1 TYPE2)) (VALUES T T)) ((EQ TYPE2 (QUOTE COMMON)) (IL:* IL:\; "Common does not list it's subtypes in the lattice, since their presence indicates that they are in COMMON.") (IF (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)) (IL:* IL:|;;| "then this is part of common. Note this will include structures etc.") (VALUES T T) (VALUES NIL T))) ((OR (NOT (MEMBER SYMBOL-TYPE1 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ))) (NOT (MEMBER SYMBOL-TYPE2 *COMMON-LISP-BASE-TYPES* :TEST (FUNCTION EQ)))) (IL:* IL:\; "one of the types is something we can't reason about (for instance a user defined type that expands into satisfies.)") (VALUES NIL NIL)) (IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.") ((EQ TYPE1 T) (IL:* IL:\; "t is not a subtype of anything but t, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 NIL) (IL:* IL:\; "nil is not a supertype of anything but nil, and that's checked above).") (VALUES NIL T)) ((EQ TYPE2 (QUOTE ATOM)) (IL:* IL:|;;| "this case could be explicitly added to the type lattice.  But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)") (IF (EQ TYPE1 (QUOTE CONS)) (IL:* IL:\; "this is the only base type that isn't a subtype of atom.") (VALUES NIL T) (VALUES T T))) ((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2) (MEMBER SYMBOL-TYPE1 (ASSOC SYMBOL-TYPE2 *BASE-TYPE-LATTICE* :TEST (FUNCTION EQ)) :TEST (FUNCTION EQ)))) (IL:* IL:|;;| "since we are now dealing with only base types, we can make sure that type1 (without its arguments) is a subtype of type2, before checking the constraints on the arguments.") (VALUES NIL T)) (T (IL:* IL:|;;| "Now check the constraints on the type arguments.") (LET ((TYPE1 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE1)) (TYPE2 (COMPLETE-META-EXPRESSION-DEFAULTS TYPE2))) (CASE (IF (CONSP TYPE1) (CAR TYPE1) TYPE1) ((ARRAY SIMPLE-ARRAY) (IL:* IL:|;;| "the type will look like (simple-array element-type dimensions)") (CL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1) TYPE1 (CL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2) TYPE2 (IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2) (EQUAL-DIMENSIONS DIMS-1 DIMS-2)) (VALUES T T) (VALUES NIL T))))) ((:DATATYPE IL:DATATYPE) (IL:* IL:|;;| "we wouldn't have made it here if they weren't both datatypes, since only datatype is a subtype of datatype in the lattice.") (VALUES (SI::SUB-DATATYPE-P (CADR TYPE1) (CADR TYPE2)) T)) ((INTEGER RATIONAL FLOAT) (CASE TYPE2 (NUMBER (IL:* IL:|;;| "number doesn't take ranges, there's nothing  to verify.") (VALUES T T)) (OTHERWISE (CL:DESTRUCTURING-BIND (NUMERIC-TYPE1 LOW1 HIGH1) TYPE1 (CL:DESTRUCTURING-BIND (NUMERIC-TYPE2 LOW2 HIGH2) TYPE2 (IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2 NUMERIC-TYPE1 NUMERIC-TYPE2) (VALUES T T) (VALUES NIL T))))))) (COMPLEX (CASE TYPE2 (NUMBER (VALUES T T)) (OTHERWISE (IL:* IL:|;;| "typep2 must be complex") (LET ((ELT-TYPE1 (CADR TYPE1)) (ELT-TYPE2 (CADR TYPE2))) (COND ((EQ ELT-TYPE2 (QUOTE *)) (VALUES T T)) ((EQ ELT-TYPE1 (QUOTE *)) (VALUES NIL T)) (T (SUBTYPEP ELT-TYPE1 ELT-TYPE2))))))) (OTHERWISE (IL:* IL:|;;| "these are two base types.  the lattice said they are subtypes, and there are no special rules on the arguments, so the result is (t t) if they are equal") (VALUES T T))))))))
+
+(DEFUN EQUAL-ELEMENT-TYPE (ELEMENT-TYPE-1 ELEMENT-TYPE-2) (IL:* IL:|;;| "returns t if they are element types for compatible array types.") (COND ((EQ ELEMENT-TYPE-2 (QUOTE *)) T) ((EQ ELEMENT-TYPE-1 (QUOTE *)) NIL) (T (EQUAL (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-1) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE-2)))))
+
+(DEFUN USEFUL-TYPE-EXPANSION-P (EXPANSION EXPANDED) (IL:* IL:|;;| "a type expansion only gained information if some expansion happened and the result isn't solely a satisfies form.") (AND EXPANDED (NOT (AND (CONSP EXPANSION) (EQ (CAR EXPANSION) (QUOTE SATISFIES))))))
+
+
+
+(IL:* IL:|;;;| "Basic deftypes")

+
+
+(DEFTYPE ATOM NIL (QUOTE (SATISFIES ATOM)))
+
+(DEFTYPE BIGNUM NIL (QUOTE (SATISFIES BIGNUMP)))
+
+(DEFTYPE BIT NIL (QUOTE (INTEGER 0 1)))
+
+(DEFTYPE CHARACTER NIL (QUOTE (SATISFIES CHARACTERP)))
+
+(DEFTYPE CONS NIL (QUOTE (:DATATYPE IL:LISTP)))
+
+(DEFTYPE DOUBLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE EQL (CL::VALUE) (IL:BQUOTE (SATISFIES (LAMBDA (CL::X) (EQL CL::X (QUOTE (IL:\\\, CL::VALUE)))))))
+
+(DEFTYPE FIXNUM NIL (IL:BQUOTE (INTEGER (IL:\\\, MOST-NEGATIVE-FIXNUM) (IL:\\\, MOST-POSITIVE-FIXNUM))))
+
+(DEFTYPE STREAM NIL (QUOTE (:DATATYPE STREAM)))
+
+(DEFTYPE FLOAT (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (:DATATYPE IL:FLOATP)) LOW HIGH))
+
+(DEFTYPE FUNCTION NIL (QUOTE (SATISFIES FUNCTIONP)))
+
+(DEFTYPE HASH-TABLE NIL (QUOTE (:DATATYPE IL:HARRAYP)))
+
+(DEFTYPE INTEGER (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (SATISFIES INTEGERP)) LOW HIGH (IL:BQUOTE (((IL:\\\, IL:MIN.INTEGER) (IL:\\\, IL:MAX.INTEGER) (SATISFIES INTEGERP)) ((IL:\\\, IL:MIN.FIXP) (IL:\\\, IL:MAX.FIXP) (OR (SATISFIES IL:SMALLP) (:DATATYPE IL:FIXP))) ((IL:\\\, IL:MIN.SMALLP) (IL:\\\, IL:MAX.SMALLP) (SATISFIES IL:SMALLP)) (0 1 (MEMBER 0 1))))))
+
+(DEFTYPE KEYWORD NIL (QUOTE (SATISFIES KEYWORDP)))
+
+(DEFTYPE LIST (&OPTIONAL TYPE) (IF (EQ TYPE (QUOTE *)) (QUOTE (OR NULL CONS)) (IL:BQUOTE (AND LIST (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
+
+(DEFTYPE LONG-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE MEMBER (&REST VALUES) (IL:BQUOTE (SATISFIES (LAMBDA (X) (MEMBER X (QUOTE (IL:\\\, VALUES)))))))
+
+(DEFTYPE MOD (N) (IL:BQUOTE (INTEGER 0 (IL:\\\, (1- N)))))
+
+(DEFTYPE NULL NIL (QUOTE (SATISFIES NULL)))
+
+(DEFTYPE NUMBER NIL (QUOTE (SATISFIES NUMBERP)))
+
+(DEFTYPE PACKAGE NIL (QUOTE (:DATATYPE PACKAGE)))
+
+(DEFTYPE CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (IL:* IL:|;;| "This is true in our implementation, but CLtL2 does not require it (it is legal for other things to be REAL; we just don't have any).") (%RANGE-TYPE (QUOTE (OR RATIONAL FLOAT)) CL::LOW CL::HIGH))
+
+(DEFTYPE SHORT-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE SIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE INTEGER) (LET ((SIZE (EXPT 2 (1- S)))) (IL:BQUOTE (INTEGER (IL:\\\, (- SIZE)) (IL:\\\, (1- SIZE)))))))
+
+(DEFTYPE STANDARD-CHAR NIL (QUOTE (SATISFIES STANDARD-CHAR-P)))
+
+(DEFTYPE STRING-CHAR NIL (QUOTE (AND CHARACTER (SATISFIES STRING-CHAR-P))))
+
+(DEFTYPE CL:BASE-CHARACTER NIL (QUOTE (SATISFIES CL::BASE-CHARACTER-P)))
+
+(DEFTYPE CL:EXTENDED-CHARACTER NIL (QUOTE (SATISFIES CL::EXTENDED-CHARACTER-P)))
+
+(DEFTYPE SINGLE-FLOAT (&OPTIONAL LOW HIGH) (IL:BQUOTE (FLOAT (IL:\\\, LOW) (IL:\\\, HIGH))))
+
+(DEFTYPE SYMBOL NIL (QUOTE (:DATATYPE IL:LITATOM)))
+
+(DEFTYPE UNSIGNED-BYTE (&OPTIONAL S) (IF (EQ S (QUOTE *)) (QUOTE (INTEGER 0 *)) (IL:BQUOTE (INTEGER 0 ((IL:\\\, (EXPT 2 S)))))))
+
+(DEFTYPE RATIONAL (&OPTIONAL LOW HIGH) (%RANGE-TYPE (QUOTE (OR RATIO INTEGER)) LOW HIGH))
+
+(DEFTYPE READTABLE NIL (QUOTE (:DATATYPE READTABLEP)))
+
+(DEFTYPE COMMON NIL (IL:* IL:|;;| "This is a hack.  (You can tell, because it uses TYPE-OF.)  However, it is correct.  (Note that even though subtypep uses expanders, there is no danger of  a loop because it quits when it reachs a satisfies clause.)") (IL:BQUOTE (SATISFIES (LAMBDA (OBJ) (VALUES (SUBTYPEP (TYPE-OF OBJ) (QUOTE COMMON)))))))
+
+(DEFTYPE COMPILED-FUNCTION NIL (QUOTE (SATISFIES COMPILED-FUNCTION-P)))
+
+(DEFTYPE SEQUENCE (&OPTIONAL TYPE) (IL:* IL:|;;| "Larry's dubious extension, that I can't remove because he wrote code that relies on it.  Actually the extension is somewhat useful, but confusing.  (it simulates the DECL facility for saying (LIST user-type).)") (IF (EQ TYPE (QUOTE *)) (QUOTE (OR VECTOR LIST)) (IL:BQUOTE (AND SEQUENCE (SATISFIES (LAMBDA (X) (EVERY (FUNCTION (LAMBDA (ELEMENT) (TYPEP ELEMENT (QUOTE (IL:\\\, TYPE))))) X)))))))
+
+
+
+(IL:* IL:|;;;| "Array Types")

+
+
+(DEFTYPE ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;;| "This type definition should not return anything other than satisfies.  Other array types are determined in terms of this one, (for subtypep's sake) so this  one must bottom out.") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES ARRAYP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE *)) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES VECTORP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IL:* IL:|;;| "CL:BASE-CHARACTER is the canonical type for CL:BASE-CHARACTER, CHARACTER, and STRING-CHAR.  For typing purposes, they have to explicitly say CL:BASE-CHARACTER to recognize only thin strings.") (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES STRINGP)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (STRINGP X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:* IL:|;;| "vector of explicit element-type") (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (VECTORP X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (ARRAYP X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
+
+(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (IL:* IL:|;;| "this type must be defined in terms of array so that subtypep can reason(?) about them.") (IL:BQUOTE (ARRAY (IL:\\\, ELEMENT-TYPE) ((IL:\\\, SIZE)))))
+
+(DEFTYPE STRING (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-STRING (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY STRING-CHAR ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMENSIONS) (IL:* IL:|;;| "Simple-array type expander") (LET ((CANONICAL-ET (IF (EQ ELEMENT-TYPE (QUOTE *)) (QUOTE *) (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE)))) (IF (TYPEP DIMENSIONS (QUOTE FIXNUM)) (SETQ DIMENSIONS (MAKE-LIST DIMENSIONS :INITIAL-ELEMENT (QUOTE *)))) (IL:* IL:|;;| "at this point, dimensions is always a list of integers or *'s, and element-type is a canonical type.") (COND ((EQ DIMENSIONS (QUOTE *)) (IF (EQ CANONICAL-ET (QUOTE *)) (QUOTE (SATISFIES XCL:SIMPLE-ARRAY-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))) ((EQ (LENGTH DIMENSIONS) 1) (LET ((SIZE (CAR DIMENSIONS))) (COND ((EQ CANONICAL-ET (QUOTE CL:BASE-CHARACTER)) (IF (EQ ELEMENT-TYPE (QUOTE CL:BASE-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%THIN-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-STRING-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))) ((EQ CANONICAL-ET (QUOTE CL:EXTENDED-CHARACTER)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-STRING-P X) (IL:%FAT-STRING-ARRAY-P X) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE))))))))))) ((OR (EQ CANONICAL-ET (QUOTE BIT)) (EQUAL CANONICAL-ET (QUOTE (UNSIGNED-BYTE 1)))) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-BIT-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-BIT-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) ((EQ CANONICAL-ET T) (IF (EQ SIZE (QUOTE *)) (QUOTE (SATISFIES SIMPLE-VECTOR-P)) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (SIMPLE-VECTOR-P X) (EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))))) (T (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ 1 (ARRAY-RANK X)) (IL:\\\,@ (IF (NOT (EQ SIZE (QUOTE *))) (IL:BQUOTE ((EQ (ARRAY-TOTAL-SIZE X) (IL:\\\, SIZE)))))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET))))))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (EQ DIM (QUOTE *)))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) ((EVERY (FUNCTION (LAMBDA (DIM) (OR (EQ DIM (QUOTE *)) (TYPEP DIM (QUOTE FIXNUM))))) DIMENSIONS) (IL:BQUOTE (SATISFIES (LAMBDA (X) (AND (XCL:SIMPLE-ARRAY-P X) (EQ (ARRAY-RANK X) (IL:\\\, (LENGTH DIMENSIONS))) (IL:\\\,@ (DO ((DIM-SPEC DIMENSIONS (CDR DIM-SPEC)) (DIM 0 (1+ DIM)) FORMS) ((NULL DIM-SPEC) FORMS) (IF (NOT (EQ (CAR DIM-SPEC) (QUOTE *))) (PUSH (IL:BQUOTE (EQ (ARRAY-DIMENSION X (IL:\\\, DIM)) (IL:\\\, (CAR DIM-SPEC)))) FORMS)))) (IL:\\\,@ (IF (NOT (EQ CANONICAL-ET (QUOTE *))) (IL:BQUOTE ((EQUAL (ARRAY-ELEMENT-TYPE X) (QUOTE (IL:\\\, CANONICAL-ET)))))))))))) (T (ERROR "Bad (final) array type designator: ~S" (IL:BQUOTE (SIMPLE-ARRAY (IL:\\\, CANONICAL-ET) (IL:\\\, DIMENSIONS))))))))
+
+(DEFTYPE SIMPLE-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY T ((IL:\\\, SIZE)))))
+
+(DEFTYPE BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
+
+(DEFTYPE SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (IL:BQUOTE (SIMPLE-ARRAY (UNSIGNED-BYTE 1) ((IL:\\\, SIZE)))))
+
+(DEFTYPE CL:BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
+
+(DEFTYPE CL:SIMPLE-BASE-STRING (&OPTIONAL CL::SIZE) (IL:BQUOTE (SIMPLE-ARRAY CL:BASE-CHARACTER ((IL:\\\, CL::SIZE)))))
+
+
+
+(IL:* IL:|;;;| "Stream types required by CLtL2")

+
+
+(DEFTYPE CL:BROADCAST-STREAM NIL (IL:BQUOTE (AND STREAM (SATISFIES XCL:BROADCAST-STREAM-P))))
+
+(DEFTYPE CL:CONCATENATED-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:CONCATENATED-STREAM-P))))
+
+(DEFTYPE CL:ECHO-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:ECHO-STREAM-P))))
+
+(DEFTYPE CL:SYNONYM-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:SYNONYM-STREAM-P))))
+
+(DEFTYPE CL:STRING-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:STRING-STREAM-P))))
+
+(DEFTYPE CL:FILE-STREAM NIL (QUOTE (AND STREAM (SATISFIES CL::FILE-STREAM-P))))
+
+(DEFTYPE CL:TWO-WAY-STREAM NIL (QUOTE (AND STREAM (SATISFIES XCL:TWO-WAY-STREAM-P))))
+
+
+
+(IL:* IL:|;;;| "Fast predicates for typep")

+
+
+(XCL:DEF-DEFINE-TYPE TYPEP "Typep evaluator for a type")
+
+(XCL:DEFDEFINER DEFTYPEP TYPEP (NAME TYPE-ARGS OBJECT-ARG &BODY BODY) (IL:* IL:|;;;| "The comment below is not necessarily true for deftype, so until the PavCompiler groks deftype, leave the eval-when alone.") (IL:* IL:|;;| "The EVAL-WHEN below should be a PROGN as soon as the old ByteCompiler/COMPILE-FILE hack is done away with.  The PavCompiler understands DEFMACRO's correctly and doesn't side-effect the environment.") (UNLESS (AND NAME (SYMBOLP NAME)) (ERROR "Illegal name used in DEFTYPEP: ~S" NAME)) (MULTIPLE-VALUE-BIND (PARSED-BODY DECLS DOCSTRING) (IL:PARSE-DEFMACRO TYPE-ARGS (QUOTE SI::%$$TYPE-ARGS) BODY NAME NIL :DEFAULT-DEFAULT (QUOTE (QUOTE *)) :PATH (QUOTE SI::%$$TYPE-ARGS)) (LET ((TYPEP-NAME (XCL:PACK (LIST "typep-evaluate-" NAME) (SYMBOL-PACKAGE NAME)))) (IL:* IL:|;;| "the eval-when insures  that the functions in the hash table are always  compiled") (IL:BQUOTE (PROGN (EVAL-WHEN (LOAD) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, TYPEP-NAME))) (FUNCTION (LAMBDA (SI::%$$OBJECT &OPTIONAL SI::%$$TYPE-ARGS) (IL:\\\,@ DECLS) (BLOCK (IL:\\\, NAME) (LET (((IL:\\\, (CAR OBJECT-ARG)) SI::%$$OBJECT)) (IL:\\\, PARSED-BODY)))))) (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) (QUOTE (IL:\\\, TYPEP-NAME))) (IL:\\\,@ (AND DOCSTRING (IL:BQUOTE ((SETF (DOCUMENTATION (QUOTE (IL:\\\, NAME)) (QUOTE TYPEP)) (IL:\\\, DOCSTRING))))))) (EVAL-WHEN (EVAL) (IL:* IL:|;;| "With redefinition, clear the hash table") (SETF (GETHASH (QUOTE (IL:\\\, NAME)) *TYPEP-HASH-TABLE*) NIL)))))))
+
+(DEFTYPEP LIST (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (LISTP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (DOLIST (L OBJECT T) (IF (NOT (TYPEP L ELEMENT-TYPE)) (RETURN NIL))))))
+
+(DEFTYPEP SEQUENCE (&OPTIONAL ELEMENT-TYPE) (OBJECT) (AND (TYPEP OBJECT (QUOTE SEQUENCE)) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EVERY (FUNCTION (LAMBDA (S) (TYPEP S ELEMENT-TYPE))) OBJECT))))
+
+(DEFTYPEP MEMBER (&REST VALUES) (OBJECT) (MEMBER OBJECT VALUES))
+
+(DEFTYPEP ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (ARRAYP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (SUBTYPEP (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
+
+(DEFTYPEP SIMPLE-ARRAY (&OPTIONAL ELEMENT-TYPE DIMS) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (XCL:SIMPLE-ARRAY-P OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (COND ((EQ DIMS (QUOTE *)) T) ((TYPEP DIMS (QUOTE FIXNUM)) (EQ (ARRAY-RANK OBJECT) DIMS)) (T (IL:* IL:|;;| "Must be a cons") (AND (EQ (ARRAY-RANK OBJECT) (LENGTH DIMS)) (DO ((I 0 (1+ I)) (D DIMS (CDR D))) ((NULL D) T) (IF (AND (TYPEP (CAR D) (QUOTE FIXNUM)) (NOT (EQ (ARRAY-DIMENSION OBJECT I) (CAR D)))) (RETURN NIL))))))))
+
+(DEFTYPEP VECTOR (&OPTIONAL ELEMENT-TYPE SIZE) (OBJECT) (IF (NOT (EQ ELEMENT-TYPE (QUOTE *))) (SETQ ELEMENT-TYPE (IL:%GET-CANONICAL-CML-TYPE ELEMENT-TYPE))) (AND (VECTORP OBJECT) (IF (EQ ELEMENT-TYPE (QUOTE *)) T (EQUAL (ARRAY-ELEMENT-TYPE OBJECT) ELEMENT-TYPE)) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP COMPLEX (&OPTIONAL TYPE) (OBJECT) (AND (COMPLEXP OBJECT) (IF (EQ TYPE (QUOTE *)) T (AND (TYPEP (REALPART OBJECT) TYPE) (TYPEP (IMAGPART OBJECT) TYPE)))))
+
+(DEFTYPEP INTEGER (&OPTIONAL LOW HIGH) (OBJECT) (AND (INTEGERP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP MOD (&OPTIONAL N) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ N (QUOTE *)) T (> N OBJECT))))
+
+(DEFTYPEP SIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (IF (EQ S (QUOTE *)) T (LET ((BOUND (ASH 1 (1- S)))) (AND (>= OBJECT (- BOUND)) (> BOUND OBJECT))))))
+
+(DEFTYPEP UNSIGNED-BYTE (&OPTIONAL S) (OBJECT) (AND (INTEGERP OBJECT) (>= OBJECT 0) (IF (EQ S (QUOTE *)) T (> (ASH 1 S) OBJECT))))
+
+(DEFTYPEP RATIONAL (&OPTIONAL LOW HIGH) (OBJECT) (AND (RATIONALP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP FLOAT (&OPTIONAL LOW HIGH) (OBJECT) (AND (FLOATP OBJECT) (COND ((EQ LOW (QUOTE *)) T) ((CONSP LOW) (> OBJECT (CAR LOW))) (T (>= OBJECT LOW))) (COND ((EQ HIGH (QUOTE *)) T) ((CONSP HIGH) (> (CAR HIGH) OBJECT)) (T (>= HIGH OBJECT)))))
+
+(DEFTYPEP STRING (&OPTIONAL SIZE) (OBJECT) (AND (STRINGP OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-STRING (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-STRING-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP SIMPLE-BIT-VECTOR (&OPTIONAL SIZE) (OBJECT) (AND (SIMPLE-BIT-VECTOR-P OBJECT) (IF (EQ SIZE (QUOTE *)) T (EQ (ARRAY-TOTAL-SIZE OBJECT) SIZE))))
+
+(DEFTYPEP EQL (CL::VALUE) (CL::OBJECT) (EQL CL::OBJECT CL::VALUE))
+
+(DEFTYPEP CL:REAL (&OPTIONAL CL::LOW CL::HIGH) (CL::OBJECT) (AND (OR (RATIONAL CL::OBJECT) (FLOATP CL::OBJECT)) (COND ((EQ CL::LOW (QUOTE *)) T) ((CONSP CL::LOW) (> CL::OBJECT (CAR CL::LOW))) (T (>= CL::OBJECT CL::LOW))) (COND ((EQ CL::HIGH (QUOTE *)) T) ((CONSP CL::HIGH) (> (CAR CL::HIGH) CL::OBJECT)) (T (>= CL::HIGH CL::OBJECT)))))
+
+
+
+(IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names")

+
+
+(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER)
+
+(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM)
+
+(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT)
+
+(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS IL:LISTP CMLTYPE CONS)
+
+(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL)
+
+(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM)
+
+(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE)
+
+(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY)
+
+(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE)
+
+(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE)
+
+
+
+(IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property")

+
+
+(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE)
+
+(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE)
+
+
+
+(IL:* IL:|;;;| "Compiler options")

+
+
+(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY 
+(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
+
+(IL:LOCALVARS . T)
+)
+)
+(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1992 1993)
+)
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CMLUNDO

@@ -0,0 +1,716 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "XCL")
+
(IL:FILECREATED "18-Oct-93 15:22:19" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLUNDO.;2"
 33104  
+
+      IL:|previous| IL:|date:| "12-Feb-92 05:57:01" 
+"{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLUNDO.;1")
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991, 1992, 1993 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CMLUNDOCOMS)
+
+(IL:RPAQQ IL:CMLUNDOCOMS

+          ((IL:VARIABLES *IN-DEFINER*)
+           (IL:FUNCTIONS NOHOOK UNDOABLY UNDOABLY-FMAKUNBOUND UNDOABLY-MAKUNBOUND UNDOABLY-SETF 
+                  UNDOHOOK UNDOABLY-PSETF UNDOABLY-POP UNDOABLY-PUSH UNDOABLY-PUSHNEW UNDOABLY-REMF 
+                  UNDOABLY-ROTATEF UNDOABLY-SHIFTF DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF 
+                  UNDOABLY-INCF UNDOABLY-PROCLAIM)
+           (IL:FUNCTIONS MAKE-UNDOABLE STOP-UNDOABLY)
+           (IL:FUNCTIONS UNDOABLY-SETF-SYMBOL-FUNCTION UNDOABLY-SETF-MACRO-FUNCTION 
+                  UNDOABLY-SET-SETF-METHOD-EXPANDER)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD 
+                                                                                     '
+                                                                        UNDOABLY-SETF-SYMBOL-FUNCTION
+                                                                                     
+                                                                                     '
+                                                                     IL:UNDOABLY-SETF-SYMBOL-FUNCTION
+                                                                                     )
+                                                                              (IL:MOVD 
+                                                                                     '
+                                                                         UNDOABLY-SETF-MACRO-FUNCTION
+                                                                                     
+                                                                                     '
+                                                                         UNDOABLY-SETF-MACRO-FUNCTION
+                                                                                     )))
+           (IL:ADDVARS (IL:LISPXFNS (PROCLAIM . UNDOABLY-PROCLAIM)
+                              (POP . UNDOABLY-POP)
+                              (PSETF . UNDOABLY-PSETF)
+                              (PUSH . UNDOABLY-PUSH)
+                              (PUSHNEW . UNDOABLY-PUSHNEW)
+                              ((REMF) . UNDOABLY-REMF)
+                              (ROTATEF . UNDOABLY-ROTATEF)
+                              (SHIFTF . UNDOABLY-SHIFTF)
+                              (DECF . UNDOABLY-DECF)
+                              (INCF . UNDOABLY-INCF)
+                              (SET . UNDOABLY-SET-SYMBOL)
+                              (MAKUNBOUND . UNDOABLY-MAKUNBOUND)
+                              (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND)))
+           (IL:FUNCTIONS GET-UNDOABLE-SETF-METHOD UNDOABLY-SET-SYMBOL UNDOABLY-SET-FDEFINITION)
+           (IL:FNS UNDOABLY-SETQ)
+           (IL:SPECIAL-FORMS UNDOABLY UNDOABLY-SETQ)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY (IL:P (IL:MOVD 
+                                                                                     '
+                                                                                  UNDOABLY-SET-SYMBOL
+                                                                                     
+                                                                                     '
+                                                                               IL:UNDOABLY-SET-SYMBOL
+                                                                                     )))
+           (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                  IL:CMLUNDO)
+           (IL:PROP :UNDOABLE-SETF-INVERSE SYMBOL-FUNCTION MACRO-FUNCTION FDEFINITION)
+           (IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS
+                  (IL:ADDVARS (IL:NLAMA UNDOABLY-SETQ)
+                         (IL:NLAML)
+                         (IL:LAMA)))))
+
+(DEFVAR *IN-DEFINER*
 NIL)
+
+(DEFUN NOHOOK
 (FN ARGS &OPTIONAL ENV &AUX (*EVALHOOK* NIL))
+   (APPLY FN ARGS))
+
+(DEFMACRO UNDOABLY
 (&REST FORMS &ENVIRONMENT ENV)
+   (WALK-FORM
+    (IL:MKPROGN FORMS)
+    :ENVIRONMENT ENV :WALK-FUNCTION
+    #'(LAMBDA
+       (X CONTEXT)
+       (COND
+          ((NOT (CONSP X))
+           X)
+          ((NOT (SYMBOLP (CAR X)))
+           X)
+          (T
+           (CASE (CAR X)
+               ((SETQ SETQ SETF) 
+                  (VALUES
+                   (IL:MKPROGN
+                    (WITH-COLLECTION
+                     (DO ((TAIL (CDR X)
+                                (CDDR TAIL)))
+                         ((NULL TAIL))
+                       (COLLECT
+                        (IF (SYMBOLP (CAR TAIL))
+                            (IF (VARIABLE-LEXICAL-P (CAR TAIL))
+                                `(SETQ ,(CAR TAIL)
+                                       ,(WALK-FORM-INTERNAL (CADR TAIL)))
+                                (PROGN (WARN "Variable ~S presumed special in UNDOABLY.. SETQ"
+                                             (CAR TAIL))
+                                       `(UNDOABLY-SET-SYMBOL
 ',(CAR TAIL)
+                                               ,(WALK-FORM-INTERNAL (CADR TAIL)))))
+                            (MULTIPLE-VALUE-BIND
+                             (FORMALS ACTUALS NEW-VALUE SETTER GETTER)
+                             (GET-UNDOABLE-SETF-METHOD
 (CAR TAIL))
+                             (IF (NULL (CDR NEW-VALUE))
+                                 `(,'LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                              (LIST X (WALK-FORM-INTERNAL Y)))
+                                                    FORMALS ACTUALS)
+                                           (,(WALK-FORM-INTERNAL (CAR NEW-VALUE))
+                                            ,(CADR TAIL)))
+                                         ,SETTER)
+
+                                 (IL:* IL:|;;| "It's one of those multiple-value jobbers...")

+
+                                 `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                            (LIST X (WALK-FORM-INTERNAL Y)))
+                                                  FORMALS ACTUALS))
+                                        (MULTIPLE-VALUE-BIND ,(MAPCAR #'WALK-FORM-INTERNAL NEW-VALUE)
+                                               ,(CADR TAIL)
+                                               ,SETTER)))))))))
+                   T))
+               (STOP-UNDOABLY (VALUES (IL:MKPROGN (CDR X))
+                                     T))
+               (T (LET ((UNDONAME (CDR (MEMBER (CAR X)
+                                              IL:LISPXFNS :TEST #'EQ))))
+                       (IF UNDONAME
+                           (CONS UNDONAME (CDR X))
+                           (IF (AND (OR (GET (CAR X)
+                                             ':DEFINER-FOR)
+                                        (GET (CAR X)
+                                             'IL:DEFINER-FOR))
+                                    (NOT *IN-DEFINER*))
+                               (LET ((*IN-DEFINER* T))
+                                    (VALUES (WALK-FORM-INTERNAL (MACROEXPAND-1 X))
+                                           T))
+                               X))))))))))
+
+(DEFUN UNDOABLY-FMAKUNBOUND
 (SYMBOL)
+   (IL:/PUTD SYMBOL NIL)
+   (IL:/REMPROP SYMBOL 'IL:MACRO-FN)
+   (IL:/REMPROP SYMBOL 'IL:SPECIAL-FORM)
+   (IL:/REMPROP SYMBOL 'IL:CODE)
+   (IL:/REMPROP SYMBOL 'IL:EXPR)
+   SYMBOL)
+
+(DEFUN UNDOABLY-MAKUNBOUND
 (SYMBOL)
+
+   (IL:* IL:|;;| "Make a symbol unbound.")

+
+   (IL:SAVESET SYMBOL 'IL:NOBIND)                            (IL:* IL:\; 
+
                                                           " unbound symbols are set to IL:NOBIND")

+   (IL:/PUTHASH SYMBOL NIL IL:COMPVARMACROHASH)              (IL:* IL:\; 
+
                                                           "remove any constant entry")

+   (IL:/REMPROP SYMBOL 'IL:GLOBALLY-SPECIAL)                 (IL:* IL:\; 
+
                                                           " left by PROCLAIM special")

+   (IL:/REMPROP SYMBOL 'IL:GLOBALVAR)                        (IL:* IL:\; "")

+   SYMBOL)
+
+(DEFMACRO UNDOABLY-SETF
 (PLACE NEW-VALUE &ENVIRONMENT ENV)
+   "UNDOable version of SETF"
+
+   (IL:* IL:|;;| "note that this is a \"one-shot\", in that (UNDOABLY (SETF (CDR (RPLACA X Y)) Z) will make the RPLACA undoable, but (UNDOABLY-SETF (CDR (RPLACA X Y)) Z) will not")

+
+   (COND
+      ((SYMBOLP PLACE)
+
+       (IL:* IL:|;;| "assumes variable is not lexical !")

+
+       `(UNDOABLY-SET-SYMBOL
 ',PLACE ,NEW-VALUE))
+      (T (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+                (GET-UNDOABLE-SETF-METHOD
 PLACE ENV)
+                (IF (NULL (CDR NEWVAL))
+                    `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                              (,(CAR NEWVAL)
+                               ,NEW-VALUE))
+                            ,SETTER)
+
+                    (IL:* IL:|;;| "It's one of those multiple-value jobbers...")

+
+                    `(LET* (,@(MAPCAR #'LIST DUMMIES VALS))
+                           (MULTIPLE-VALUE-BIND ,NEWVAL ,NEW-VALUE ,SETTER)))))))
+
+(DEFUN UNDOHOOK
 (FORM ENV &AUX (*APPLYHOOK* NIL))        (IL:* IL:\; 
+
                                                           "Edited 10-Feb-92 12:15 by jrb:")

+   (IF (ATOM FORM)
+       (EVAL FORM ENV)
+       (CASE (CAR FORM)
+           ((SETQ SETQ SETF) 
+
+              (IL:* IL:|;;| "The following mess is to insure that the evaluation of the last pair gets returned as the value of the form immediately, so any multiple-values generated by it get back to the top level.")

+
+              (LET
+               ((TAIL (CDR FORM)))
+               (FLET
+                ((SET-IT-UNDOABLY
+                  NIL
+                  (IF (SYMBOLP (CAR TAIL))
+                      (UNDOABLY-SET-SYMBOL
 (POP TAIL)
+                             (UNDOHOOK
 (POP TAIL)
+                                    ENV)
+                             ENV)
+                      (EVAL
+
+                       (IL:* IL:|;;| "real cop-out , just to EVAL of making it undoable ")

+
+                       (MULTIPLE-VALUE-BIND
+                        (FORMALS VALS NEW-VALUE SETTER GETTER)
+                        (GET-UNDOABLE-SETF-METHOD
 (POP TAIL)
+                               ENV)
+                        (IF (NULL (CDR NEW-VALUE))
+                            `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                       (LIST X (LIST 'UNDOABLY Y)))
+                                             FORMALS VALS)
+                                    (,(CAR NEW-VALUE)
+                                     (UNDOABLY
 ,(POP TAIL))))
+                                   ,SETTER)
+
+                            (IL:* IL:|;;| "It's one of those multiple-value jobbers...")

+
+                            `(LET* (,@(MAPCAR #'(LAMBDA (X Y)
+                                                       (LIST X (LIST 'UNDOABLY Y)))
+                                             FORMALS VALS))
+                                   (MULTIPLE-VALUE-BIND ,NEW-VALUE (UNDOABLY
 ,(POP TAIL))
+                                          ,SETTER))))
+                       ENV))))
+                (DO NIL
+                    ((NULL (CDDR TAIL))
+                     (SET-IT-UNDOABLY))
+                  (SET-IT-UNDOABLY)))))
+           (STOP-UNDOABLY 
+
+              (IL:* IL:|;;| "special signal to not undo")

+
+              (IL:\\EVAL-PROGN (CDR FORM)
+                     ENV))
+           (T (LET ((UNDONAME (CDR (MEMBER (CAR FORM)
+                                          IL:LISPXFNS :TEST #'EQ))))
+                   (IF UNDONAME
+                       (EVALHOOK (CONS UNDONAME (CDR FORM))
+                              'UNDOHOOK
+                              'NOHOOK ENV)
+                       (EVALHOOK FORM 'UNDOHOOK 'NOHOOK ENV)))))))
+
+(DEFMACRO UNDOABLY-PSETF
 (&REST ARGS &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| "parallel version of UNDOABLY-SETF - simple minded version")

+
+   (COND
+      ((NULL ARGS)
+       NIL)
+      (T `(PROG1 NIL
+              (UNDOABLY-SETF
 ,(POP ARGS)
+                     (PROG1 ,(POP ARGS)
+                         (UNDOABLY-PSETF
 ,@ARGS)))))))
+
+(DEFMACRO UNDOABLY-POP
 (PLACE &ENVIRONMENT ENV)
+   (IF (SYMBOLP PLACE)
+       `(PROG1 (CAR ,PLACE)
+            (UNDOABLY-SETQ
 ,PLACE (CDR ,PLACE)))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD
 PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        ,(LIST (CAR NEWVAL)
+                               GETTER))
+                      (PROG1 (CAR ,(CAR NEWVAL))
+                          (SETQ ,(CAR NEWVAL)
+                                (CDR ,(CAR NEWVAL)))
+                          ,SETTER)))))
+
+(DEFMACRO UNDOABLY-PUSH
 (OBJ PLACE &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| "Takes an object and a location holding a list.  Conses the object onto PLACE returning then modified list.")

+
+   (IF (SYMBOLP PLACE)
+       `(UNDOABLY-SETQ
 ,PLACE (CONS ,OBJ ,PLACE))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD
 PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        (,(CAR NEWVAL)
+                         (CONS ,OBJ ,GETTER)))
+                      ,SETTER))))
+
+(DEFMACRO UNDOABLY-PUSHNEW
 (OBJ PLACE &REST KEYS &ENVIRONMENT ENV)
+   (IF (SYMBOLP PLACE)
+       `(UNDOABLY-SETQ
 ,PLACE (ADJOIN ,OBJ ,PLACE ,@KEYS))
+       (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+              (GET-UNDOABLE-SETF-METHOD
 PLACE ENV)
+              `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                        (,(CAR NEWVAL)
+                         (ADJOIN ,OBJ ,GETTER ,@KEYS)))
+                      ,SETTER))))
+
+(DEFMACRO UNDOABLY-REMF
 (PLACE INDICATOR &ENVIRONMENT ENV)
+   (MULTIPLE-VALUE-BIND (DUMMIES VALS NEWVAL SETTER GETTER)
+          (GET-UNDOABLE-SETF-METHOD
 PLACE ENV)
+          (LET ((IND-TEMP (GENSYM))
+                (LOCAL1 (GENSYM))
+                (LOCAL2 (GENSYM)))
+               `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                         (,(CAR NEWVAL)
+                          ,GETTER)
+                         (,IND-TEMP ,INDICATOR))
+                       (DO ((,LOCAL1 ,(CAR NEWVAL)
+                                   (CDDR ,LOCAL1))
+                            (,LOCAL2 NIL ,LOCAL1))
+                           ((ATOM ,LOCAL1)
+                            NIL)
+                         (COND
+                            ((ATOM (CDR ,LOCAL1))
+                             (ERROR "Odd-length property list in REMF."))
+                            ((EQ (CAR ,LOCAL1)
+                                 ,IND-TEMP)
+                             (COND
+                                (,LOCAL2 (IL:/RPLACD (CDR ,LOCAL2)
+                                                (CDDR ,LOCAL1))
+                                       (RETURN T))
+                                (T (SETQ ,(CAR NEWVAL)
+                                         (CDDR ,(CAR NEWVAL)))
+                                   ,SETTER
+                                   (RETURN T))))))))))
+
+(DEFMACRO UNDOABLY-ROTATEF
 (&REST ARGS &ENVIRONMENT ENV)
+
+   (IL:* IL:|;;| 
+
 "Assigns to each place the value of the form to its right; last gets first. Returns NIL.")

+
+   (IL:* IL:|;;| "forms evaluated in order")

+
+   (COND
+      ((NULL ARGS)
+       NIL)
+      ((NULL (CDR ARGS))
+       `(PROGN ,(CAR ARGS)
+               NIL))
+      (T (LISP::ROTATEF-INTERNAL ARGS ENV 'GET-UNDOABLE-SETF-METHOD))))
+
+(DEFMACRO UNDOABLY-SHIFTF
 (&REST ARGS &ENVIRONMENT ENV)
+   (COND
+      ((OR (NULL ARGS)
+           (NULL (CDR ARGS)))
+       (ERROR "SHIFTF needs at least two arguments"))
+      (T (LISP::SHIFTF-INTERNAL ARGS ARGS 'GET-UNDOABLE-SETF-METHOD))))
+
+(DEFDEFINER DEFINE-UNDOABLE-MODIFY-MACRO
 IL:FUNCTIONS (NAME LAMBDA-LIST FUNCTION &OPTIONAL 
+                                                                DOC-STRING)
+   (LET
+    ((OTHER-ARGS NIL)
+     (REST-ARG NIL))
+    (DO ((LL LAMBDA-LIST (CDR LL))
+         (ARG NIL))
+        ((NULL LL))
+      (SETQ ARG (CAR LL))
+      (COND
+         ((EQ ARG '&OPTIONAL))
+         ((EQ ARG '&REST)
+          (SETQ REST-ARG (CADR LL))
+          (RETURN NIL))
+         ((SYMBOLP ARG)
+          (PUSH ARG OTHER-ARGS))
+         (T (PUSH (CAR ARG)
+                  OTHER-ARGS))))
+    (SETQ OTHER-ARGS (REVERSE OTHER-ARGS))
+    `(DEFMACRO ,NAME (SI::%$$MODIFY-MACRO-FORM ,@LAMBDA-LIST &ENVIRONMENT 
+                            SI::%$$MODIFY-MACRO-ENVIRONMENT)
+        ,DOC-STRING (MULTIPLE-VALUE-BIND
+                     (DUMMIES VALS NEWVAL SETTER GETTER)
+                     (GET-UNDOABLE-SETF-METHOD
 SI::%$$MODIFY-MACRO-FORM 
+                            SI::%$$MODIFY-MACRO-ENVIRONMENT)
+                     (MULTIPLE-VALUE-BIND
+                      (DUMMIES VALS NEWVALS SETTER GETTER)
+                      (GET-SETF-METHOD SI::%$$MODIFY-MACRO-FORM SI::%$$MODIFY-MACRO-ENVIRONMENT)
+                      `(,'LET* (,@(MAPCAR #'LIST DUMMIES VALS)
+                                (,(CAR NEWVALS)
+                                 ,,(IF REST-ARG
+                                       `(LIST* ',FUNCTION GETTER ,@OTHER-ARGS ,REST-ARG)
+                                       `(LIST ',FUNCTION GETTER ,@OTHER-ARGS))))
+                              ,SETTER))))))
+
+(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-DECF
 (&OPTIONAL (DELTA 1))
+                                                -
)
+
+(DEFINE-UNDOABLE-MODIFY-MACRO UNDOABLY-INCF
 (&OPTIONAL (DELTA 1))
+                                                +)
+
+(DEFUN UNDOABLY-PROCLAIM
 (PROCLAMATION)
+
+   (IL:* IL:|;;| "Undoable version of PROCLAIM.")

+
+   (WHEN (CONSP PROCLAMATION)
+       (CASE (CAR PROCLAMATION)
+           (SPECIAL (DOLIST (X (CDR PROCLAMATION))
+                        (UNDOABLY
 (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                            T)
+                               (SETF (IL:VARIABLE-GLOBAL-P X)
+                                     NIL)
+                               (SETF (CONSTANTP X)
+                                     NIL))))
+           (GLOBAL (DOLIST (X (CDR PROCLAMATION))
+                       (UNDOABLY
 (SETF (IL:VARIABLE-GLOBAL-P X)
+                                           T)
+                              (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                    NIL)
+                              (SETF (CONSTANTP X)
+                                    NIL))))
+           (SI::CONSTANT (DOLIST (X (CDR PROCLAMATION))
+                             (UNDOABLY
 (SETF (CONSTANTP X)
+                                                 T)
+                                    (SETF (IL:VARIABLE-GLOBAL-P X)
+                                          NIL)
+                                    (SETF (IL:VARIABLE-GLOBALLY-SPECIAL-P X)
+                                          NIL))))
+           (DECLARATION (DOLIST (X (CDR PROCLAMATION))
+                            (UNDOABLY
 (SETF (DECL-SPECIFIER-P X)
+                                                T))))
+           (NOTINLINE (DOLIST (X (CDR PROCLAMATION))
+                          (UNDOABLY
 (SETF (GLOBALLY-NOTINLINE-P X)
+                                              T))))
+           (INLINE (DOLIST (X (CDR PROCLAMATION))
+                       (UNDOABLY
 (SETF (GLOBALLY-NOTINLINE-P X)
+                                           NIL)))))))
+
+(DEFUN MAKE-UNDOABLE
 (FORM &OPTIONAL ENV)
+   (LIST 'UNDOABLY FORM))
+
+(DEFMACRO STOP-UNDOABLY
 (&REST FORMS)
+
+   (IL:* IL:|;;| "evaluate forms -- inside UNDOABLY, stops transformation")

+
+   (IL:MKPROGN FORMS))
+
+(DEFUN UNDOABLY-SETF-SYMBOL-FUNCTION
 (SYMBOL DEFINITION)
+
+   (IL:* IL:|;;| 
+
 "NOTE:  If you change this version, be sure to change the not-undoable version on LLSYMBOL!")

+
+   (IL:* IL:|;;| " undoable inverse of SYMBOL-FUNCTION")

+
+   (IL:VIRGINFN SYMBOL T)
+   (COND
+      ((CONSP DEFINITION)
+
+       (IL:* IL:|;;| "Either it's a LAMBDA form or one of the special lists put together by SYMBOL-FUNCTION for macros and special forms.")

+
+       (CASE (CAR DEFINITION)
+           (:MACRO (UNDOABLY-SETF
 (MACRO-FUNCTION SYMBOL)
+                          (CDR DEFINITION)))
+           (:SPECIAL-FORM (UNDOABLY-SETF
 (GET SYMBOL 'IL:SPECIAL-FORM)
+                                 (CDR DEFINITION)))
+           (T (IL:/PUTD SYMBOL DEFINITION T))))
+
+      (IL:* IL:|;;| "If it's (SETF (SYMBOL-FUNCTION 'FOO) 'BAR) then we give FOO the same definition as BAR.  This isn't quite like Lucid and Symbolics, but it will do for now.")

+
+      ((AND (SYMBOLP DEFINITION)
+            (NOT (NULL DEFINITION)))
+       (IL:/PUTD SYMBOL (IL:GETD DEFINITION)
+              T))
+
+      (IL:* IL:|;;| "It's probably a compiled-code object or an interpreted closure.  In any case, go ahead and put it in there; if it's illegal, we'll find out when we try to apply it.")

+
+      (T (IL:/PUTD SYMBOL DEFINITION T)))
+
+   (IL:* IL:|;;| "(SETF (SYMBOL-FUNCTION ...) ...) is supposed to remove macro definitions.  We only remove the ones that could come from DEFMACRO.")

+
+   (UNLESS (OR (NULL DEFINITION)
+               (AND (CONSP DEFINITION)
+                    (EQ (CAR DEFINITION)
+                        :MACRO)))
+       (IL:/REMPROP SYMBOL 'IL:MACRO-FN))
+   DEFINITION)
+
+(DEFUN UNDOABLY-SETF-MACRO-FUNCTION
 (X BODY)
+
+   (IL:* IL:|;;| "undoable setf of macro-function")

+
+   (IL:* IL:|;;| 
+
 "NOTE:  If you change this, be sure to change the not-undoable version on CMLMACROS!")

+
+   (PROG1 (UNDOABLY-SETF
 (GET X 'IL:MACRO-FN)
+                 BODY)
+       (AND (IL:GETD X)
+            (CASE (IL:ARGTYPE X)
+                ((1 3)                                       (IL:* IL:\; 
+
                                                         "Leave Interlisp nlambda definition alone")

+)
+                (OTHERWISE (IL:/PUTD X NIL))))))
+
+(DEFUN UNDOABLY-SET-SETF-METHOD-EXPANDER
 (NAME EXPANDER)
+
+   (IL:* IL:|;;| "If you change this, change the normal version on SETF-RUNTIME too.")

+
+   (IL:/REMPROP NAME 'IL:SETF-INVERSE)
+   (IL:/REMPROP NAME ':SETF-INVERSE)
+   (IL:/REMPROP NAME ':SHARED-SETF-INVERSE)
+   (UNDOABLY-SETF
 (GET NAME ':SETF-METHOD-EXPANDER)
+          EXPANDER))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY 
+
+(IL:MOVD 'UNDOABLY-SETF-SYMBOL-FUNCTION 'IL:UNDOABLY-SETF-SYMBOL-FUNCTION)
+
+(IL:MOVD 'UNDOABLY-SETF-MACRO-FUNCTION 'UNDOABLY-SETF-MACRO-FUNCTION)
+)
+
+(IL:ADDTOVAR IL:LISPXFNS
 (PROCLAIM . UNDOABLY-PROCLAIM)
+                             (POP . UNDOABLY-POP)
+                             (PSETF . UNDOABLY-PSETF)
+                             (PUSH . UNDOABLY-PUSH)
+                             (PUSHNEW . UNDOABLY-PUSHNEW)
+                             ((REMF) . UNDOABLY-REMF)
+                             (ROTATEF . UNDOABLY-ROTATEF)
+                             (SHIFTF . UNDOABLY-SHIFTF)
+                             (DECF . UNDOABLY-DECF)
+                             (INCF . UNDOABLY-INCF)
+                             (SET . UNDOABLY-SET-SYMBOL)
+                             (MAKUNBOUND . UNDOABLY-MAKUNBOUND)
+                             (FMAKUNBOUND . UNDOABLY-FMAKUNBOUND))
+
+(DEFUN GET-UNDOABLE-SETF-METHOD
 (FORM &OPTIONAL ENVIRONMENT &AUX TEMP)
+                                                             (IL:* IL:\; 
+
                                                           "Edited  6-Feb-92 16:07 by jrb:")

+   (COND
+      ((SYMBOLP FORM)
+       (VALUES NIL NIL (LIST (SETQ TEMP (GENSYM)))
+              `(IL:UNDOABLY-SET-SYMBOL ',FORM ,TEMP)
+              FORM))
+      ((NOT (CONSP FORM))
+       (LISP::SETF-ERROR FORM))
+      ((SETQ TEMP (IL:LOCAL-MACRO-FUNCTION (CAR FORM)
+                         ENVIRONMENT))
+
+       (IL:* IL:|;;| "always expand local macros")

+
+       (GET-UNDOABLE-SETF-METHOD
 (FUNCALL TEMP FORM ENVIRONMENT)
+              ENVIRONMENT))
+      ((SETQ TEMP (GET (CAR FORM)
+                       ':UNDOABLE-SETF-INVERSE))
+
+       (IL:* IL:|;;| "found a special undoable property -- use it")

+
+       (LISP::GET-SIMPLE-SETF-METHOD FORM TEMP))
+      (T (BLOCK DONE
+             (MULTIPLE-VALUE-BIND
+              (DUMMIES VALS NEWVAL SETTER GETTER)
+              (COND
+                 ((SETQ TEMP (OR (GET (CAR FORM)
+                                      ':SETF-INVERSE)
+                                 (GET (CAR FORM)
+                                      'IL:SETF-INVERSE)
+                                 (GET (CAR FORM)
+                                      'IL:SETFN)))
+                  (LISP::GET-SIMPLE-SETF-METHOD FORM TEMP))
+                 ((SETQ TEMP (GET (CAR FORM)
+                                  ':SHARED-SETF-INVERSE))
+                  (LISP::GET-SHARED-SETF-METHOD FORM TEMP))
+                 ((SETQ TEMP (OR (GET (CAR FORM)
+                                      ':SETF-METHOD-EXPANDER)
+                                 (GET (CAR FORM)
+                                      'IL:SETF-METHOD-EXPANDER)))
+                  (FUNCALL TEMP FORM ENVIRONMENT))
+                 (T (MULTIPLE-VALUE-BIND (MAC MORE)
+                           (MACROEXPAND-1 FORM ENVIRONMENT)
+                           (IF (AND MORE (NOT (EQ MAC FORM)))
+                               (RETURN-FROM DONE (GET-UNDOABLE-SETF-METHOD
 MAC ENVIRONMENT))
+                               (LISP::DEFUN-SETF-METHOD FORM ENVIRONMENT)))))
+
+              (IL:* IL:|;;| 
+
            "this is lexically correct, but doesn't work in bytecompiler, interlisp")

+
+              (IL:* IL:|;;| "(cl:values dummies vals newval `(cl:labels ((undostore (,@newval) (undosave (list #'undostore ,getter)) ,setter)) (undostore ,@newval)) getter)")

+
+              (IL:* IL:|;;| "so, instead we do the following, which binds the dummies too so that there are no free references. LABELS is used because the thing saved on the undo list is also saved when the UNDO is undefined.")

+
+              (IL:* IL:|;;| " ")

+
+              (VALUES DUMMIES VALS NEWVAL
+                     (IF (NULL (CDR NEWVAL))
+                         `(IL:COMMON-LISP (LABELS ((UNDOSTORE (,@DUMMIES ,@NEWVAL)
+                                                          (IL:UNDOSAVE (LIST #'UNDOSTORE ,@DUMMIES
+                                                                             ,GETTER))
+                                                          ,SETTER))
+                                                 (UNDOSTORE ,@DUMMIES ,@NEWVAL)))
+
+                         (IL:* IL:|;;| "It's one of those multiple-value jobbers...")

+
+                         `(IL:COMMON-LISP (LABELS ((UNDOSTORE (,@DUMMIES ,@NEWVAL)
+                                                          (IL:UNDOSAVE (LIST* #'UNDOSTORE
+                                                                              ,@DUMMIES
+                                                                              (MULTIPLE-VALUE-LIST
+                                                                               ,GETTER)))
+                                                          ,SETTER))
+                                                 (UNDOSTORE ,@DUMMIES ,@NEWVAL))))
+                     GETTER))))))
+
+(DEFUN UNDOABLY-SET-SYMBOL
 (SYMBOL VALUE &OPTIONAL ENVIRONMENT)
+   (BLOCK UNDOABLY-SET-SYMBOL
+       (WHEN ENVIRONMENT
+
+           (IL:* IL:|;;| 
+
         "This function only saves undo info when there is no lexical binding for the variable.")

+
+           (SETQ ENVIRONMENT (IL:ENVIRONMENT-VARS ENVIRONMENT))
+           (LOOP (IF (NULL ENVIRONMENT)
+                     (RETURN NIL))
+                 (IF (EQ SYMBOL (CAR ENVIRONMENT))
+
+                     (IL:* IL:|;;| "found a binding for this symbol")

+
+                     (PROGN (IF (EQ (CAR (SETQ ENVIRONMENT (CDR ENVIRONMENT)))
+                                    IL:*SPECIAL-BINDING-MARK*)
+
+                                (IL:* IL:|;;| 
+
                           "it is a special binding, or a mark that we are using the special value")

+
+                                (RETURN NIL)                 (IL:* IL:\; "return from WHILE")

+                                )
+                            (RPLACA ENVIRONMENT VALUE)
+
+                            (IL:* IL:|;;| "smash new value in")

+
+                            (RETURN-FROM UNDOABLY-SET-SYMBOL VALUE))
+                     (SETQ ENVIRONMENT (CDDR ENVIRONMENT)))))
+
+       (IL:* IL:|;;| "no environment, or not found.  ")

+
+       (LET
+        ((VP (IL:\\STKSCAN SYMBOL)))
+        (COND
+           ((EQ (IL:\\HILOC VP)
+                IL:\\STACKHI)
+            (IL:\\PUTBASEPTR VP 0 VALUE))
+           (T (WHEN (CONSTANTP SYMBOL)
+                  (UNLESS (EQL VALUE (IL:GETTOPVAL SYMBOL))
+                         (CERROR "Go ahead and set it" "Attempt to set constant ~S to ~S" SYMBOL 
+                                VALUE)))
+              (LET ((OLDVAL (IL:\\GETBASEPTR VP 0))
+                    TEM)
+                   (UNLESS (OR (NULL IL:LISPXHIST)
+                               (AND (SETQ TEM (SOME #'(LAMBDA (X)
+                                                             (AND (CONSP X)
+                                                                  (EQ (CAR X)
+                                                                      'IL:/SETTOPVAL)
+                                                                  (EQ (CADR X)
+                                                                      SYMBOL)))
+                                                    (IL:LISTGET1 IL:LISPXHIST 'IL:SIDE)))
+                                    (NOT (TAILP TEM (IL:LISTP IL:UNDOSIDE0)))))
+
+                       (IL:* IL:|;;| "special optimization from Interlisp: don't save more than one assignment of the same variable in the same event(!)")

+
+                       (IL:UNDOSAVE (LIST 'IL:/SETTOPVAL SYMBOL OLDVAL))))
+              (IL:\\RPLPTR VP 0 VALUE))))))
+
+(DEFUN UNDOABLY-SET-FDEFINITION
 (FUNCTION-NAME NEWVALUE)
+
+   (IL:* IL:|;;| "If you change this, be sure to change the normal version on LLSYMBOL")

+
+   (IF (LISP::SETF-NAME-P FUNCTION-NAME)
+       (LET* ((REAL-NAME (SECOND FUNCTION-NAME))
+              (DEFUN-SETF-NAME (DEFUN-SETF-NAME REAL-NAME)))
+
+             (IL:* IL:|;;| "We smash the SYMBOL-FUNCTION of DEFUN-SETF-NAME rather than just changing the :SETF-DEFUN property to insure the SETF function's having a consistent name")

+
+             (UNDOABLY-SETF
 (GET REAL-NAME :SETF-DEFUN)
+                    DEFUN-SETF-NAME)
+             (UNDOABLY-SETF
 (SYMBOL-FUNCTION DEFUN-SETF-NAME)
+                    NEWVALUE))
+       (UNDOABLY-SETF-SYMBOL-FUNCTION
 FUNCTION-NAME NEWVALUE))
+   NEWVALUE)
+(IL:DEFINEQ
+
+(UNDOABLY-SETQ

+  (IL:NLAMBDA VARVALUE                                       (IL:* IL:\; 
+
                                                           "Edited  8-Oct-87 18:54 by jop")

+                                                             (IL:* IL:\; "Interlisp version")

+    (UNDOABLY-SET-SYMBOL
 (CAR VARVALUE)
+           (IL:\\EVPROG1 (CDR VARVALUE)))))
+)
+
+(DEFINE-SPECIAL-FORM UNDOABLY
 (&REST FORMS &ENVIRONMENT ENV)
+   (LOOP (IF (NULL (CDR FORMS))
+             (RETURN (UNDOHOOK
 (CAR FORMS)
+                            ENV))
+             (UNDOHOOK
 (POP FORMS)
+                    ENV))))
+
+(DEFINE-SPECIAL-FORM UNDOABLY-SETQ
 (&REST TAIL &ENVIRONMENT ENV)
+   (LET (VALUE)
+        (LOOP (IF (NULL TAIL)
+                  (RETURN NIL)
+                  (SETQ VALUE (UNDOABLY-SET-SYMBOL
 (POP TAIL)
+                                     (EVAL (POP TAIL)
+                                           ENV)
+                                     ENV))))
+        VALUE))
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DONTEVAL@COMPILE IL:DOCOPY 
+
+(IL:MOVD 'UNDOABLY-SET-SYMBOL 'IL:UNDOABLY-SET-SYMBOL)
+)
+
+(IL:PUTPROPS IL:CMLUNDO
 IL:FILETYPE
 :COMPILE-FILE)
+
+(IL:PUTPROPS IL:CMLUNDO
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "XCL" :PACKAGE "XCL"))
+
+(IL:PUTPROPS SYMBOL-FUNCTION
 :UNDOABLE-SETF-INVERSE
 UNDOABLY-SETF-SYMBOL-FUNCTION)
+
+(IL:PUTPROPS MACRO-FUNCTION
 :UNDOABLE-SETF-INVERSE
 UNDOABLY-SETF-MACRO-FUNCTION)
+
+(IL:PUTPROPS FDEFINITION
 :UNDOABLE-SETF-INVERSE
 UNDOABLY-SET-FDEFINITION)
+(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY IL:COMPILERVARS 
+
+(IL:ADDTOVAR IL:NLAMA
 UNDOABLY-SETQ)
+
+(IL:ADDTOVAR IL:NLAML
 )
+
+(IL:ADDTOVAR IL:LAMA
 )
+)
+(IL:PUTPROPS IL:CMLUNDO IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 1993))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL (31241 31634 (UNDOABLY-SETQ 31254 . 31632)))))
+IL:STOP

CLTL2/CMLWALK

@@ -0,0 +1,560 @@
+(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
+
(FILECREATED "18-Oct-93 15:25:46" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLWALK.;2"
 27482  
+
+      previous date%: " 3-Sep-91 17:53:09" "{Pele:mv:envos}<LispCore>Sources>CLTL2>CMLWALK.;1")
+
+
+(* ; "
+Copyright (c) 1986, 1987, 1990, 1991, 1993 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(PRETTYCOMPRINT CMLWALKCOMS)
+
+(RPAQQ CMLWALKCOMS

+       [(FUNCTIONS XCL:ONCE-ONLY)
+                                                             (* ; 
+
                       "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.")

+        (VARIABLES *WALK-FUNCTION* *WALK-FORM* *DECLARATIONS* *LEXICAL-VARIABLES* *ENVIRONMENT* 
+               *WALK-COPY*)
+        (FUNCTIONS WITH-NEW-CONTOUR NOTE-LEXICAL-BINDING NOTE-DECLARATION)
+        (FUNCTIONS VARIABLE-SPECIAL-P VARIABLE-LEXICAL-P GET-WALKER-TEMPLATE)
+        (FUNCTIONS WALK-FORM)
+        (FNS WALK-FORM-INTERNAL WALK-TEMPLATE WALK-TEMPLATE-HANDLE-REPEAT 
+             WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-LIST WALK-RECONS)
+        (FUNCTIONS WALK-RELIST*)
+        (FNS WALK-DECLARATIONS WALK-ARGLIST WALK-LAMBDA)
+        (COMS (PROP WALKER-TEMPLATE LISP:COMPILER-LET)
+              (FNS WALK-COMPILER-LET)
+              (PROP WALKER-TEMPLATE DECLARE)
+              (FNS WALK-UNEXPECTED-DECLARE)
+              (PROP WALKER-TEMPLATE LET PROG LET* PROG*)
+              (FNS WALK-LET WALK-LET* WALK-LET/LET*)
+              (PROP WALKER-TEMPLATE LISP:TAGBODY)
+              (FNS WALK-TAGBODY)
+              (PROP WALKER-TEMPLATE FUNCTION LISP:FUNCTION GO LISP:IF LISP:MULTIPLE-VALUE-CALL 
+                    LISP:MULTIPLE-VALUE-PROG1 PROGN LISP:PROGV QUOTE LISP:RETURN-FROM RETURN 
+                    LISP:SETQ LISP:BLOCK LISP:CATCH LISP:EVAL-WHEN THE LISP:THROW LISP:UNWIND-PROTECT
+                    LOAD-TIME-EVAL COND LISP:UNWIND-PROTECT SETQ AND OR))
+        (COMS 
+              (* ;; "for Interlisp")

+
+              (PROP WALKER-TEMPLATE RPAQ? RPAQ XNLSETQ ERSETQ NLSETQ RESETVARS))
+        (PROP FILETYPE CMLWALK)
+        (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
+               (ADDVARS (NLAMA)
+                      (NLAML)
+                      (LAMA WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE 
+                            WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS
+                            WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE 
+                            WALK-FORM-INTERNAL])
+
+(DEFMACRO XCL:ONCE-ONLY
 (XCL::VARS &BODY XCL::BODY)
+
+(* ;;; "ONCE-ONLY assures that the forms given as vars are evaluated in the proper order, once only. Used in the body of macro definitions. Taken from Zeta Lisp.")

+
+   [LET* [(XCL::GENSYM-VAR (LISP:GENSYM))
+          (XCL::RUN-TIME-VARS (LISP:GENSYM))
+          (XCL::RUN-TIME-VALS (LISP:GENSYM))
+          (XCL::EXPAND-TIME-VAL-FORMS (FOR
 XCL::VAR IN
 XCL::VARS
+                                         COLLECT
 `(LISP:IF (OR (LISP:SYMBOLP ,XCL::VAR)
+                                                                   (LISP:CONSTANTP ,XCL::VAR))
+                                                          ,XCL::VAR
+                                                          (LET ((,XCL::GENSYM-VAR (LISP:GENSYM)))
+                                                               (LISP:PUSH ,XCL::GENSYM-VAR
+                                                                      ,XCL::RUN-TIME-VARS)
+                                                               (LISP:PUSH ,XCL::VAR 
+                                                                      ,XCL::RUN-TIME-VALS)
+                                                               ,XCL::GENSYM-VAR))]
+         `(LET* [,XCL::RUN-TIME-VARS ,XCL::RUN-TIME-VALS
+                       (XCL::WRAPPED-BODY (LET ,(FOR
 XCL::VAR IN
 XCL::VARS AS
 
+                                                                            XCL::EXPAND-TIME-VAL-FORM
+                                                   IN
 XCL::EXPAND-TIME-VAL-FORMS
+                                                   COLLECT
 (LIST XCL::VAR 
+                                                                     XCL::EXPAND-TIME-VAL-FORM))
+                                               ,@XCL::BODY]
+                `(LET ,(FOR
 XCL::RUN-TIME-VAR IN
 (LISP:REVERSE XCL::RUN-TIME-VARS)
+                          AS
 XCL::RUN-TIME-VAL IN
 (LISP:REVERSE XCL::RUN-TIME-VALS)
+                          COLLECT
 (LIST XCL::RUN-TIME-VAR XCL::RUN-TIME-VAL))
+                      ,XCL::WRAPPED-BODY])
+
+
+
+(* ; "not a wonderful place for it, but CMLMACROS comes too eraly in the loadup.")

+
+
+(LISP:DEFVAR *WALK-FUNCTION*
 NIL
+   "the function being called on each sub-form in the code-walker")
+
+(LISP:DEFVAR *WALK-FORM*

+   "When the first argument to the IF template in the code-walker is a list, it will be evaluated with *walk-form* bound to the form currently being walked."
+)
+
+(LISP:DEFVAR *DECLARATIONS*
 "a list of the declarations currently in effect while codewalking")
+
+(LISP:DEFVAR *LEXICAL-VARIABLES*
 NIL                   (* ; 
+
                                       "used in walker to hold list of lexical variables available")

+   )
+
+(LISP:DEFVAR *ENVIRONMENT*

+   "while codewalking, this is the lexical environment as far as macros are concerned")
+
+(LISP:DEFVAR *WALK-COPY*

+   "while walking, this is true if we are making a copy of the expresion being walked")
+
+(DEFMACRO WITH-NEW-CONTOUR
 (&BODY BODY)
+
+   (* ;; "WITH-NEW-CONTOUR is used to enter a new lexical binding contour which inherits from the exisiting one.  Using WITH-NEW-CONTOUR is often overkill: It would suffice for the the walker to rebind *LEXICAL-VARIABLES* and *DECLARATIONS* when walking LET and rebind *ENVIRONMENT* and *DECLARATIONS* when walking MACROLET etc.  WITH-NEW-CONTOUR is much more convenient and just as correct.  *")

+
+   `(LET ((*DECLARATIONS* NIL)
+          (*LEXICAL-VARIABLES* *LEXICAL-VARIABLES*)
+          (*ENVIRONMENT* *ENVIRONMENT*))
+         ,@BODY))
+
+(DEFMACRO NOTE-LEXICAL-BINDING
 (THING)
+   `(LISP:PUSH ,THING *LEXICAL-VARIABLES*))
+
+(DEFMACRO NOTE-DECLARATION
 (LISP:DECLARATION)
+   `(LISP:PUSH ,LISP:DECLARATION *DECLARATIONS*))
+
+(LISP:DEFUN VARIABLE-SPECIAL-P
 (VAR)
+                                                             (* lmm "27-May-86 15:42")

+   (OR (for
 DECL in
 *DECLARATIONS* do
 (AND (EQ (CAR DECL)
+                                                           'LISP:SPECIAL)
+                                                       (FMEMB VAR (CDR DECL))
+                                                       (RETURN T)))
+       (VARIABLE-GLOBALLY-SPECIAL-P VAR)))
+
+(LISP:DEFUN VARIABLE-LEXICAL-P
 (VAR)
+                                                             (* lmm "11-Apr-86 10:59")

+   (AND (NOT (VARIABLE-SPECIAL-P
 VAR))
+        (LISP:MEMBER VAR *LEXICAL-VARIABLES* :TEST (FUNCTION EQ
))))
+
+(LISP:DEFUN GET-WALKER-TEMPLATE
 (X)
+                                                             (* lmm "24-May-86 14:48")

+   (LISP:IF (NOT (LISP:SYMBOLP X))
+       '(LISP:LAMBDA :REPEAT (:EVAL))
+       (GET X 'WALKER-TEMPLATE)))
+
+(LISP:DEFUN WALK-FORM
 (FORM &KEY ((:DECLARATIONS *DECLARATIONS*)
+                                      NIL)
+                                ((:LEXICAL-VARIABLES *LEXICAL-VARIABLES*)
+                                 NIL)
+                                ((:ENVIRONMENT *ENVIRONMENT*)
+                                 NIL)
+                                ((:WALK-FUNCTION *WALK-FUNCTION*)
+                                 (FUNCTION (LISP:LAMBDA (X IGNORE)
+                                                  IGNORE X)))
+                                ((:COPY *WALK-COPY*)
+                                 T))
+   "Walk FORM, expanding all macros, calling :WALK-FUNCTION on each subfof :COPY is true (default), will return the expansion"
+   (WALK-FORM-INTERNAL
 FORM ':EVAL))
+(DEFINEQ
+
+(WALK-FORM-INTERNAL

+  [LISP:LAMBDA (FORM CONTEXT &AUX FN TEMPLATE WALK-NO-MORE-P NEWFORM)
+                                                             (* lmm "24-May-86 20:28")

+
+         (* ;; "WALK-FORM-INTERNAL is the main driving function for the code walker.  It takes a form and the current context and walks the form calling itself or the appropriate template recursively.")

+
+         (LISP:MULTIPLE-VALUE-SETQ (NEWFORM WALK-NO-MORE-P)
+                (LISP:FUNCALL *WALK-FUNCTION* FORM CONTEXT))
+         (COND
+            (WALK-NO-MORE-P NEWFORM)
+            ((NOT (EQ FORM NEWFORM))
+             (WALK-FORM-INTERNAL
 NEWFORM CONTEXT))
+            ((NOT (LISP:CONSP FORM))
+             FORM)
+            ((NOT (LISP:SYMBOLP (CAR FORM)))
+             (WALK-TEMPLATE
 FORM '(:CALL :REPEAT (:EVAL))
+                    CONTEXT))
+            ((SETQ TEMPLATE (GET-WALKER-TEMPLATE
 (CAR FORM)))
+             (LISP:IF (LISP:SYMBOLP TEMPLATE)
+                 (LISP:FUNCALL TEMPLATE FORM CONTEXT)
+                 (WALK-TEMPLATE
 FORM TEMPLATE CONTEXT)))
+            ((NEQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM *ENVIRONMENT*)))
+             (WALK-FORM-INTERNAL
 FORM CONTEXT))
+            (T 
+               (* ;; "Otherwise, walk the form as if its just a standard function call using a template for standard function call.")

+
+               (WALK-TEMPLATE
 FORM '(:CALL :REPEAT (:EVAL))
+                      CONTEXT])
+
+(WALK-TEMPLATE

+  [LISP:LAMBDA (FORM TEMPLATE CONTEXT)                       (* lmm "24-May-86 16:43")

+         (LISP:IF (LISP:ATOM TEMPLATE)
+             (LISP:ECASE TEMPLATE
+                 ((CALL :CALL) (if
 (LISP:CONSP FORM)
+                                   then
 (WALK-LAMBDA
 FORM NIL)
+                                 else
 FORM))
+                 ((QUOTE NIL PPE :ERROR) FORM)
+                 ((:EVAL EVAL :FUNCTION FUNCTION :TEST TEST :EFFECT EFFECT :RETURN RETURN) 
+                    (WALK-FORM-INTERNAL
 FORM ':EVAL))
+                 ((SET :SET) (WALK-FORM-INTERNAL
 FORM ':SET))
+                 (LISP:LAMBDA (WALK-LAMBDA
 FORM CONTEXT)))
+             (CASE (CAR TEMPLATE)
+                 (LISP:IF (LET ((*WALK-FORM* FORM))
+                               (WALK-TEMPLATE
 FORM (COND
+                                                          ((LISP:IF (LISTP (LISP:SECOND TEMPLATE))
+                                                               (LISP:EVAL (LISP:SECOND TEMPLATE))
+                                                               (LISP:FUNCALL (LISP:SECOND TEMPLATE)
+                                                                      FORM))
+                                                           (LISP:THIRD TEMPLATE))
+                                                          (T (LISP:FOURTH TEMPLATE)))
+                                      CONTEXT)))
+                 ((REPEAT :REPEAT) (WALK-TEMPLATE-HANDLE-REPEAT
 FORM (CDR TEMPLATE)
+                                          (LISP:NTHCDR (- (LISP:LENGTH FORM)
+                                                          (LISP:LENGTH (CDDR TEMPLATE)))
+                                                 FORM)
+                                          CONTEXT))
+                 (T [COND
+                       ((LISP:ATOM FORM)
+                        FORM)
+                       (T (WALK-RECONS
 FORM (WALK-TEMPLATE
 (CAR FORM)
+                                                       (CAR TEMPLATE)
+                                                       CONTEXT)
+                                 (WALK-TEMPLATE
 (CDR FORM)
+                                        (CDR TEMPLATE)
+                                        CONTEXT])))])
+
+(WALK-TEMPLATE-HANDLE-REPEAT

+  (LISP:LAMBDA (FORM TEMPLATE STOP-FORM CONTEXT)             (* lmm "11-Apr-86 12:05")

+         (LISP:IF (EQ FORM STOP-FORM)
+             (WALK-TEMPLATE
 FORM (CDR TEMPLATE)
+                    CONTEXT)
+             (WALK-TEMPLATE-HANDLE-REPEAT-1
 FORM TEMPLATE (CAR TEMPLATE)
+                    STOP-FORM CONTEXT))))
+
+(WALK-TEMPLATE-HANDLE-REPEAT-1

+  [LISP:LAMBDA (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM CONTEXT)
+                                                             (* lmm "24-May-86 16:43")

+         (COND
+            ((NULL FORM)
+             NIL)
+            ((EQ FORM STOP-FORM)
+             (LISP:IF (NULL REPEAT-TEMPLATE)
+                 (WALK-TEMPLATE
 STOP-FORM (CDR TEMPLATE)
+                        CONTEXT)
+                 (LISP:ERROR 
+      "While handling repeat:
+                     ~%%~Ran into stop while still in repeat template.")))
+            ((NULL REPEAT-TEMPLATE)
+             (WALK-TEMPLATE-HANDLE-REPEAT-1
 FORM TEMPLATE (CAR TEMPLATE)
+                    STOP-FORM CONTEXT))
+            (T (WALK-RECONS
 FORM (WALK-TEMPLATE
 (CAR FORM)
+                                            (CAR REPEAT-TEMPLATE)
+                                            CONTEXT)
+                      (WALK-TEMPLATE-HANDLE-REPEAT-1
 (CDR FORM)
+                             TEMPLATE
+                             (CDR REPEAT-TEMPLATE)
+                             STOP-FORM CONTEXT])
+
+(WALK-LIST

+  [LAMBDA (LIST FN)                                          (* lmm "24-May-86 16:43")

+                                                             (* copy list walking each element)

+    (LISP:IF LIST
+        (WALK-RECONS
 LIST (LISP:FUNCALL FN (CAR LIST))
+               (WALK-LIST
 (CDR LIST)
+                      FN)))])
+
+(WALK-RECONS

+  (LISP:LAMBDA (X CAR CDR)                                   (* lmm "24-May-86 16:43")

+         (LISP:IF *WALK-COPY*
+             (LISP:IF (OR (NOT (EQ (CAR X)
+                                   CAR))
+                          (NOT (EQ (CDR X)
+                                   CDR)))
+                 (CONS CAR CDR)
+                 X)
+             NIL)))
+)
+
+(DEFMACRO WALK-RELIST*
 (X FIRST &REST LISP:REST)
+   (LISP:IF LISP:REST
+       `(WALK-RECONS
 ,X ,FIRST (WALK-RELIST*
 (CDR ,X)
+                                          ,@LISP:REST))
+       FIRST))
+(DEFINEQ
+
+(WALK-DECLARATIONS

+  [LISP:LAMBDA (BODY FN &OPTIONAL DOC-STRING-P DECLARATIONS &AUX (FORM (CAR BODY)))
+                                                             (* lmm "18-Jun-86 14:35")

+                                                             (* skips over declarations)

+         (COND
+            ((AND (STRINGP FORM)                             (* might be a doc string *)

+                  (CDR BODY)                                 (* isn't the returned value *)

+                  (NULL DOC-STRING-P)                        (* no doc string yet *)

+                  (NULL DECLARATIONS))                       (* no declarations yet *)

+             (WALK-RECONS
 BODY FORM (WALK-DECLARATIONS
 (CDR BODY)
+                                               FN T)))
+            ((AND (LISTP FORM)
+                  (EQ (CAR FORM)
+                      'DECLARE))                             (* Got a real declaration.
+
                                                           Record it, look for more.
+
                                                           *)

+             (LISP:DOLIST (LISP:DECLARATION (CDR FORM))
+                 (NOTE-DECLARATION
 LISP:DECLARATION)
+                 (LISP:PUSH LISP:DECLARATION DECLARATIONS))
+             (WALK-RECONS
 BODY FORM (WALK-DECLARATIONS
 (CDR BODY)
+                                               FN DOC-STRING-P DECLARATIONS)))
+            ([AND (LISP:CONSP FORM)
+                  (NULL (GET-WALKER-TEMPLATE
 (CAR FORM)))
+                  (NOT (EQ FORM (SETQ FORM (LISP:MACROEXPAND-1 FORM *ENVIRONMENT*]
+
+         (* * When we macroexpanded this form we got something else back.
+
       Maybe this is a macro which expanded into a declare? Recurse to find out.)

+
+             (WALK-DECLARATIONS
 (CONS FORM (CDR BODY))
+                    FN DOC-STRING-P DECLARATIONS))
+            (T 
+
+         (* Now that we have walked and recorded the declarations, call the function our 
+
       caller provided to expand the body. We call that function rather than passing 
+
       the real-body back, because we are RECONSING up the new body.)

+
+               (LISP:FUNCALL FN BODY])
+
+(WALK-ARGLIST

+  [LISP:LAMBDA (ARGLIST CONTEXT &OPTIONAL DESTRUCTURINGP &AUX ARG)
+                                                             (* lmm "24-May-86 16:44")

+         (COND
+            ((NULL ARGLIST)
+             NIL)
+            [(LISP:SYMBOLP (LISP:SETQ ARG (CAR ARGLIST)))
+             (OR (LISP:MEMBER ARG LISP:LAMBDA-LIST-KEYWORDS :TEST (FUNCTION EQ
))
+                 (NOTE-LEXICAL-BINDING
 ARG))
+             (WALK-RECONS
 ARGLIST ARG (WALK-ARGLIST

+                                           (CDR ARGLIST)
+                                           CONTEXT
+                                           (AND DESTRUCTURINGP (NOT (LISP:MEMBER
+                                                                     ARG LISP:LAMBDA-LIST-KEYWORDS 
+                                                                     :TEST (FUNCTION EQ
]
+            [(LISP:CONSP ARG)
+             (PROG1 (LISP:IF DESTRUCTURINGP
+                        (WALK-ARGLIST
 ARG CONTEXT DESTRUCTURINGP)
+                        (WALK-RECONS
 ARGLIST (WALK-RELIST*
 ARG (CAR ARG)
+                                                        (WALK-FORM-INTERNAL
 (CADR ARG)
+                                                               ':EVAL)
+                                                        (CDDR ARG))
+                               (WALK-ARGLIST
 (CDR ARGLIST)
+                                      CONTEXT NIL)))
+                 (LISP:IF (LISP:SYMBOLP (CAR ARG))
+                     (NOTE-LEXICAL-BINDING
 (CAR ARG))
+                     (NOTE-LEXICAL-BINDING
 (CADAR ARG)))
+                 (OR (NULL (CDDR ARG))
+                     (NOT (LISP:SYMBOLP (CADDR ARG)))
+                     (NOTE-LEXICAL-BINDING
 ARG)))]
+            (T (LISP:ERROR "Can't understand something in the arglist ~S" ARGLIST])
+
+(WALK-LAMBDA

+  [LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 16:44")

+         (WITH-NEW-CONTOUR
 (LET* [(ARGLIST (CADR FORM))
+                                      (BODY (CDDR FORM))
+                                      (WALKED-ARGLIST NIL)
+                                      (WALKED-BODY (WALK-DECLARATIONS

+                                                    BODY
+                                                    (FUNCTION (LISP:LAMBDA
+                                                               (REAL-BODY)
+                                                               (LISP:SETQ WALKED-ARGLIST
+                                                                      (WALK-ARGLIST
 ARGLIST 
+                                                                             CONTEXT))
+                                                               (WALK-TEMPLATE

+                                                                REAL-BODY
+                                                                '(:REPEAT (:EVAL))
+                                                                CONTEXT]
+                                     (WALK-RELIST*
 FORM (CAR FORM)
+                                            WALKED-ARGLIST WALKED-BODY])
+)
+
+(PUTPROPS LISP:COMPILER-LET
 WALKER-TEMPLATE
 WALK-COMPILER-LET)
+(DEFINEQ
+
+(WALK-COMPILER-LET

+  [LISP:LAMBDA (FORM CONTEXT)                                (* gbn " 7-Aug-86 18:21")

+                                                             (* ; 
+
                                             "bind the variables, but then return the COMPILER-LET")

+         (LET [(VARS (LISP:MAPCAR [FUNCTION (LAMBDA (X)
+                                              (LISP:IF (LISP:CONSP X)
+                                                  (CAR X)
+                                                  X)]
+                            (CADR FORM)))
+               (VALS (LISP:MAPCAR (FUNCTION (LISP:LAMBDA (X)
+                                                   (LISP:IF (LISP:CONSP X)
+                                                       (LISP:EVAL (CADR X))
+                                                       NIL)))
+                            (CADR FORM]
+              (LISP:PROGV VARS VALS
+                  (WALK-TEMPLATE
 FORM '(NIL NIL :REPEAT (:EVAL)
+                                                  :RETURN)
+                         CONTEXT))])
+)
+
+(PUTPROPS DECLARE
 WALKER-TEMPLATE
 WALK-UNEXPECTED-DECLARE)
+(DEFINEQ
+
+(WALK-UNEXPECTED-DECLARE

+  (LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 22:27")

+         (DECLARE
 (IGNORE CONTEXT))
+         (LISP:WARN "Encountered declare ~S in a place where a declare was not expected." FORM)
+         FORM))
+)
+
+(PUTPROPS LET
 WALKER-TEMPLATE
 WALK-LET)
+
+(PUTPROPS PROG
 WALKER-TEMPLATE
 WALK-LET)
+
+(PUTPROPS LET*
 WALKER-TEMPLATE
 WALK-LET*)
+
+(PUTPROPS PROG*
 WALKER-TEMPLATE
 WALK-LET*)
+(DEFINEQ
+
+(WALK-LET

+  (LISP:LAMBDA (FORM CONTEXT)
+         (WALK-LET/LET*
 FORM CONTEXT NIL)))
+
+(WALK-LET*

+  (LISP:LAMBDA (FORM CONTEXT)
+         (WALK-LET/LET*
 FORM CONTEXT T)))
+
+(WALK-LET/LET*

+  [LISP:LAMBDA
+   (FORM CONTEXT SEQUENTIALP)                                (* lmm "24-May-86 16:44")

+   (LET
+    ((OLD-DECLARATIONS *DECLARATIONS*)
+     (OLD-LEXICAL-VARIABLES *LEXICAL-VARIABLES*))
+    (WITH-NEW-CONTOUR

+     (LET* [(LET/LET* (CAR FORM))
+            (BINDINGS (CADR FORM))
+            (BODY (CDDR FORM))
+            WALKED-BINDINGS
+            (WALKED-BODY
+             (WALK-DECLARATIONS

+              BODY
+              (FUNCTION (LISP:LAMBDA
+                         (REAL-BODY)
+                         [LISP:SETQ WALKED-BINDINGS
+                                (WALK-LIST
 BINDINGS
+                                       (FUNCTION (LAMBDA (BINDING)
+                                                   (LISP:IF (LISP:SYMBOLP BINDING)
+                                                       (PROG1 BINDING (NOTE-LEXICAL-BINDING

+                                                                       BINDING))
+                                                       (PROG1 (LET ((*DECLARATIONS* OLD-DECLARATIONS)
+                                                                    (*LEXICAL-VARIABLES* (LISP:IF 
+                                                                                          SEQUENTIALP
+                                                                                             
+                                                                                  *LEXICAL-VARIABLES*
+                                                                                             
+                                                                                OLD-LEXICAL-VARIABLES)
+                                                                           ))
+                                                                   (WALK-RELIST*

+                                                                    BINDING
+                                                                    (CAR BINDING)
+                                                                    (WALK-FORM-INTERNAL

+                                                                     (CADR BINDING)
+                                                                     CONTEXT)
+                                                                    (CDDR BINDING)))
+                                                           (NOTE-LEXICAL-BINDING
 (CAR BINDING))))
+                                                   ]
+                         (WALK-TEMPLATE
 REAL-BODY '(:REPEAT (:EVAL))
+                                CONTEXT]
+           (WALK-RELIST*
 FORM LET/LET* WALKED-BINDINGS WALKED-BODY])
+)
+
+(PUTPROPS LISP:TAGBODY
 WALKER-TEMPLATE
 WALK-TAGBODY)
+(DEFINEQ
+
+(WALK-TAGBODY

+  [LISP:LAMBDA (FORM CONTEXT)                                (* lmm "24-May-86 16:44")

+         (WALK-RECONS
 FORM (CAR FORM)
+                (WALK-LIST
 (CDR FORM)
+                       (FUNCTION (LAMBDA (X)
+                                   (WALK-FORM-INTERNAL
 X (LISP:IF (LISP:SYMBOLP X)
+                                                                 'QUOTE
+                                                                 CONTEXT)])
+)
+
+(PUTPROPS FUNCTION
 WALKER-TEMPLATE
 (NIL :CALL))
+
+(PUTPROPS LISP:FUNCTION
 WALKER-TEMPLATE
 (NIL :CALL))
+
+(PUTPROPS GO
 WALKER-TEMPLATE
 (NIL NIL))
+
+(PUTPROPS LISP:IF
 WALKER-TEMPLATE
 (NIL :TEST :RETURN :RETURN))
+
+(PUTPROPS LISP:MULTIPLE-VALUE-CALL
 WALKER-TEMPLATE
 (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:MULTIPLE-VALUE-PROG1
 WALKER-TEMPLATE
 (NIL :RETURN :REPEAT (:EVAL)))
+
+(PUTPROPS PROGN
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:PROGV
 WALKER-TEMPLATE
 (NIL :EVAL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS QUOTE
 WALKER-TEMPLATE
 (NIL QUOTE))
+
+(PUTPROPS LISP:RETURN-FROM
 WALKER-TEMPLATE
 (NIL NIL :EVAL))
+
+(PUTPROPS RETURN
 WALKER-TEMPLATE
 (NIL :EVAL))
+
+(PUTPROPS LISP:SETQ
 WALKER-TEMPLATE
 (NIL :REPEAT (:SET :EVAL)))
+
+(PUTPROPS LISP:BLOCK
 WALKER-TEMPLATE
 (NIL NIL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:CATCH
 WALKER-TEMPLATE
 (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LISP:EVAL-WHEN
 WALKER-TEMPLATE
 (NIL NIL :REPEAT (:EVAL)))
+
+(PUTPROPS THE
 WALKER-TEMPLATE
 (NIL NIL :EVAL))
+
+(PUTPROPS LISP:THROW
 WALKER-TEMPLATE
 (NIL :EVAL :EVAL))
+
+(PUTPROPS LISP:UNWIND-PROTECT
 WALKER-TEMPLATE
 (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS LOAD-TIME-EVAL
 WALKER-TEMPLATE
 (NIL :EVAL))
+
+(PUTPROPS COND
 WALKER-TEMPLATE
 [NIL :REPEAT ((:REPEAT (:EVAL])
+
+(PUTPROPS LISP:UNWIND-PROTECT
 WALKER-TEMPLATE
 (NIL :EVAL :REPEAT (:EVAL)))
+
+(PUTPROPS SETQ
 WALKER-TEMPLATE
 (NIL :SET :EVAL))
+
+(PUTPROPS AND
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS OR
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+
+
+(* ;; "for Interlisp")

+
+
+(PUTPROPS RPAQ?
 WALKER-TEMPLATE
 (NIL :SET :EVAL))
+
+(PUTPROPS RPAQ
 WALKER-TEMPLATE
 (NIL :SET :EVAL))
+
+(PUTPROPS XNLSETQ
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS ERSETQ
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS NLSETQ
 WALKER-TEMPLATE
 (NIL :REPEAT (:EVAL)))
+
+(PUTPROPS RESETVARS
 WALKER-TEMPLATE
 WALK-LET)
+
+(PUTPROPS CMLWALK
 FILETYPE
 :COMPILE-FILE)
+(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS 
+
+(ADDTOVAR NLAMA
 )
+
+(ADDTOVAR NLAML
 )
+
+(ADDTOVAR LAMA
 WALK-TAGBODY WALK-LET/LET* WALK-LET* WALK-LET WALK-UNEXPECTED-DECLARE 
+                         WALK-COMPILER-LET WALK-LAMBDA WALK-ARGLIST WALK-DECLARATIONS WALK-RECONS 
+                         WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE 
+                         WALK-FORM-INTERNAL)
+)
+(PUTPROPS CMLWALK COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1993))
+(DECLARE%: DONTCOPY
+  (FILEMAP (NIL (8105 14049 (WALK-FORM-INTERNAL 8115 . 9572) (WALK-TEMPLATE 9574 . 11843) (
+WALK-TEMPLATE-HANDLE-REPEAT 11845 . 12206) (WALK-TEMPLATE-HANDLE-REPEAT-1 12208 . 13310) (WALK-LIST 
+13312 . 13665) (WALK-RECONS 13667 . 14047)) (14259 19629 (WALK-DECLARATIONS 14269 . 16481) (
+WALK-ARGLIST 16483 . 18330) (WALK-LAMBDA 18332 . 19627)) (19702 20803 (WALK-COMPILER-LET 19712 . 20801
+)) (20872 21155 (WALK-UNEXPECTED-DECLARE 20882 . 21153)) (21358 24219 (WALK-LET 21368 . 21461) (
+WALK-LET* 21463 . 21553) (WALK-LET/LET* 21555 . 24217)) (24282 24766 (WALK-TAGBODY 24292 . 24764)))))
+STOP

CLTL2/COMMON-LISP-PACKAGE

@@ -0,0 +1,38 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")
+
(FILECREATED " 8-Apr-92 23:35:08" |{DSK}<usr>local>lde>lispcore>sources>COMMON-LISP-PACKAGE.;4|
 10139  
+
+      |changes| |to:|  (FUNCTIONS CREATE-CL-PACKAGE)
+
+      |previous| |date:| " 8-Apr-92 16:51:03" 
+|{DSK}<usr>local>lde>lispcore>sources>COMMON-LISP-PACKAGE.;3|)
+
+
+; Copyright (c) 1991, 1992 by Venue Corporation.  All rights reserved.
+
+(PRETTYCOMPRINT COMMON-LISP-PACKAGECOMS)
+
+(RPAQQ COMMON-LISP-PACKAGECOMS ((VARIABLES *COMMON-LISP-PACKAGE* NEWCLSYMS OLDCLSYMS XCLCLSYMS SPLITCLSYMS STRANGECLSYMS) (FUNCTIONS CRUNCH-FILES CREATE-CL-PACKAGE FLIP-CL) (PROP FILETYPE COMMON-LISP-PACKAGE)))
+
+(DEFGLOBALVAR *COMMON-LISP-PACKAGE* NIL "Place holder for the COMMON-LISP package variable")
+
+(CL:DEFPARAMETER NEWCLSYMS (QUOTE ("*BREAK-ON-SIGNALS*" "*COMPILE-FILE-PATHNAME*" "*COMPILE-FILE-TRUENAME*" "*COMPILE-PRINT*" "*COMPILE-VERBOSE*" "*DEBUGGER-HOOK*" "*LOAD-PATHNAME*" "*LOAD-PRINT*" "*LOAD-TRUENAME*" "*PRINT-LINES*" "*PRINT-MISER-WIDTH*" "*PRINT-PPRINT-DISPATCH*" "*PRINT-READABLY*" "*PRINT-RIGHT-MARGIN*" "*READ-EVAL*" "ABORT" "AUGMENT-ENVIRONMENT" "BASE-CHARACTER" "BASE-STRING" "BROADCAST-STREAM" "BROADCAST-STREAM-STREAMS" "CELL-ERROR-NAME" "COMPILE-FILE-PATHNAME" "COMPILER-MACRO-FUNCTION" "COMPILER-MACROEXPAND" "COMPILER-MACROEXPAND-1" "COMPLEMENT" "COMPUTE-RESTARTS" "CONCATENATED-STREAM" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTINUE" "COPY-PPRINT-DISPATCH" "DECLAIM" "DECLARATION-INFORMATION" "DEFINE-COMPILER-MACRO" "DEFINE-CONDITION" "DEFINE-DECLARATION" "DESTRUCTURING-BIND" "DIVISION-BY-ZERO" "DYNAMIC-EXTENT" "ECHO-STREAM" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "ENCLOSE" "END-OF-FILE" "EXTENDED-CHARACTER" "FDEFINITION" "FILE-ERROR" "FILE-ERROR-PATHNAME" "FILE-STREAM" "FILE-STRING-LENGTH" "FIND-RESTART" "FLOATING-POINT-INEXACT" "FLOATING-POINT-INVALID-OPERATION" "FLOATING-POINT-OVERFLOW" "FLOATING-POINT-UNDERFLOW" "FORMATTER" "FUNCTION-INFORMATION" "FUNCTION-LAMBDA-EXPRESSION" "HANDLER-CASE" "HANDLER-BIND" "HASH-TABLE-REHASH-SIZE" "HASH-TABLE-REHASH-THRESHOLD" "HASH-TABLE-SIZE" "HASH-TABLE-TEST" "IGNORE-ERRORS" "INTERACTIVE-STREAM-P" "INVOKE-DEBUGGER" "INVOKE-RESTART" "INVOKE-RESTART-INTERACTIVELY" "LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT" "LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT" "LEAST-POSITIVE-NORMALIZED-LONG-FLOAT" "LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT" "LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT" "LOAD-LOGICAL-PATHNAME-TRANSLATIONS" "LOAD-TIME-EVAL" "LOAD-TIME-VALUE" "LOGICAL-PATHNAME" "LOGICAL-PATHNAME-TRANSLATIONS" "MAKE-CONDITION" "MAKE-LOAD-FORM" "MAKE-LOAD-FORM-SAVING-SLOTS" "MAP-INTO" "MUFFLE-WARNING" "NTH-VALUE" "OPEN-STREAM-P" "PACKAGE-ERROR" "PARSE-ERROR" "PARSE-MACRO" "PATHNAME-MATCH-P" "PPRINT-DISPATCH" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-FILL" "PPRINT-INDENT" "PPRINT-LINEAR" "PPRINT-LOGICAL-BLOCK" "PPRINT-NEWLINE" "PPRINT-POP" "PPRINT-TAB" "PPRINT-TABULAR" "PRINT-NOT-READABLE" "PRINT-UNREADABLE-OBJECT" "PROGRAM-ERROR" "READER-ERROR" "READTABLE-CASE" "READTABLE-CASE" "REAL" "REALP" "RESTART" "RESTART-BIND" "RESTART-CASE" "SET-PPRINT-DISPATCH" "SIMPLE-BASE-STRING" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "STORE-VALUE" "STREAM-ERROR-STREAM" "STREAM-EXTERNAL-FORMAT" "STRING-STREAM" "STYLE-WARNING" "SYNONYM-STREAM" "SYNONYM-STREAM-SYMBOL" "TRANSLATE-LOGICAL-PATHNAME" "TRANSLATE-PATHNAME" "TWO-WAY-STREAM" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR-DATUM" "UNBOUND-SLOT" "UNBOUND-VARIABLE" "UPGRADED-ARRAY-ELEMENT-TYPE" "UPGRADED-COMPLEX-PART-TYPE" "USE-VALUE" "VARIABLE-INFORMATION" "WILD-PATHNAME-P" "WITH-COMPILATION-UNIT" "WITH-CONDITION-RESTARTS" "WITH-HASH-TABLE-ITERATOR" "WITH-PACKAGE-ITERATOR" "WITH-SIMPLE-RESTART" "WITH-STANDARD-IO-SYNTAX")))
+
+(CL:DEFPARAMETER OLDCLSYMS (QUOTE ("COMMON" "COMMONP" "STRING-CHAR" "STRING-CHAR-P" "INT-CHAR" "COMPILER-LET" "CHAR-BIT" "SET-CHAR-BIT" "*MODULES*" "PROVIDE" "REQUIRE" "CHAR-FONT-LIMIT" "CHAR-BITS-LIMIT" "CHAR-BITS" "CHAR-FONT" "MAKE-CHAR" "CHAR-CONTROL-BIT" "CHAR-META-BIT" "CHAR-SUPER-BIT" "CHAR-HYPER-BIT" "*BREAK-ON-WARNINGS*")) "Symbols in LISP and not in COMMON-LISP")
+
+(CL:DEFPARAMETER XCLCLSYMS (QUOTE ("ABORT" "ARITHMETIC-ERROR" "ARITHMETIC-ERROR-OPERANDS" "ARITHMETIC-ERROR-OPERATION" "BROADCAST-STREAM-STREAMS" "CELL-ERROR" "CELL-ERROR-NAME" "CONCATENATED-STREAM-STREAMS" "CONDITION" "CONTROL-ERROR" "DEFINE-CONDITION" "DEFPACKAGE" "DESTRUCTURING-BIND" "DELETE-PACKAGE" "ECHO-STREAM-INPUT-STREAM" "ECHO-STREAM-OUTPUT-STREAM" "END-OF-FILE" "HANDLER-BIND" "IGNORE-ERRORS" "MAKE-CONDITION" "OPEN-STREAM-P" "PACKAGE-ERROR" "PACKAGE-ERROR-PACKAGE" "SERIOUS-CONDITION" "SIGNAL" "SIMPLE-CONDITION" "SIMPLE-CONDITION-FORMAT-ARGUMENTS" "SIMPLE-CONDITION-FORMAT-STRING" "SIMPLE-ERROR" "SIMPLE-TYPE-ERROR" "SIMPLE-WARNING" "STORAGE-CONDITION" "STORE-VALUE" "STREAM-ERROR" "STREAM-ERROR-STREAM" "SYNONYM-STREAM-SYMBOL" "TWO-WAY-STREAM-INPUT-STREAM" "TWO-WAY-STREAM-OUTPUT-STREAM" "TYPE-ERROR" "TYPE-ERROR-EXPECTED-TYPE" "UNBOUND-VARIABLE" "UNDEFINED-FUNCTION" "USE-VALUE" "WARNING")))
+
+(CL:DEFPARAMETER SPLITCLSYMS (QUOTE ("LOCALLY" "IN-PACKAGE")))
+
+(CL:DEFPARAMETER STRANGECLSYMS (QUOTE (("LISP" "SIMPLE-STRING" "*GENSYM-COUNTER*") ("XCL" "ROW-MAJOR-AREF"))) "Symbols in CL that are predefined in the loadup in another package")
+
+(CL:DEFUN CRUNCH-FILES (FL) (CL:WHEN (AND FL (CL:SYMBOLP FL)) (CL:SETQ FL (LIST FL))) (CL:DOLIST (F FL) (CL:FORMAT T "Crunching ~a~%" F) (FLIP-CL :LISP) (LOAD F (QUOTE ALLPROP)) (FLIP-CL :NOWHERE) (MAKEFILE F (QUOTE NEW)) (CL:IF (CL:PROBE-FILE (CONCAT F ".DFASL")) (CL:COMPILE-FILE F) (FAKE-COMPILE-FILE F)) (CL:FORMAT T "Done crunching ~a~%" F)))
+
+(CL:DEFUN CREATE-CL-PACKAGE NIL (* \; "Edited  8-Apr-92 20:15 by jrb:") (* |;;| "First, rename the LISP package to get its nicknames out of our way") (CL:RENAME-PACKAGE (CL:FIND-PACKAGE "LISP") "LISP" NIL NIL) (* |;;| "Then create the COMMON-LISP package and friends") (CL:UNLESS (CL:FIND-PACKAGE "COMMON-LISP") (* |;;| "For the moment, no nicknames for COMMON-LISP; FLIP-CL can be used to fix this later.") (SETQ *COMMON-LISP-PACKAGE* (CL:MAKE-PACKAGE "COMMON-LISP" :USE NIL)) (CL:MAKE-PACKAGE "COMMON-LISP-USER" :USE (QUOTE ("COMMON-LISP" "XCL")))) (LET ((WEIRDTAG (CONS NIL NIL)) (OLDPROP (CONS NIL NIL)) (UNSHAREDPROP (CONS NIL NIL)) I) (* |;;| "Flag the atoms in LISP that are not going to be shared into COMMON-LISP") (CL:DOLIST (I OLDCLSYMS) (PUT (CL:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG OLDPROP)) (CL:DOLIST (I SPLITCLSYMS) (PUT (CL:FIND-SYMBOL I *LISP-PACKAGE*) WEIRDTAG UNSHAREDPROP)) (* |;;| "OK, crunch the external symbols in LISP.  We may eventually rehome these symbols into COMMON-LISP") (CL:DO-EXTERNAL-SYMBOLS (I *LISP-PACKAGE*) (LET ((WEIRD? (GET I WEIRDTAG)) S) (COND ((EQ WEIRD? OLDPROP) (* \; "Just leave it alone") (REMPROP I WEIRDTAG)) ((EQ WEIRD? UNSHAREDPROP) (* \; "Export a new, unshared symbol") (EXPORT (CL:INTERN (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*) (REMPROP I WEIRDTAG)) ((NULL WEIRD?) (* \; "Share symbol; if it's already there, shadow it") (CL:IF (SETQ S (CL:FIND-SYMBOL (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*)) (CL:UNLESS (EQ S I) (CL:SHADOWING-IMPORT I *COMMON-LISP-PACKAGE*)) (IMPORT I *COMMON-LISP-PACKAGE*)) (EXPORT I *COMMON-LISP-PACKAGE*)) (T (* \; "VERY unlikely...") (ERROR "Garbage on property list during LISP->COMMON-LISP import" (CONS I WEIRD?)))))) (* |;;| "Handle the few strange CLsymbols (ones that for one reason or another already exist in another package).") (CL:DOLIST (SL STRANGECLSYMS) (LET ((P (CL:FIND-PACKAGE (CAR SL))) OLDS) (CL:DOLIST (S (CDR SL)) (IF (SETQ OLDS (CL:FIND-SYMBOL S P)) THEN (IMPORT OLDS *COMMON-LISP-PACKAGE*) (EXPORT OLDS *COMMON-LISP-PACKAGE*))))) (* |;;| "And snarf the XCL symbols that need to be shared with COMMON-LISP") (LET ((XCLP (CL:FIND-PACKAGE "XCL"))) (CL:DOLIST (I XCLCLSYMS) (IMPORT (CL:FIND-SYMBOL I XCLP) *COMMON-LISP-PACKAGE*) (EXPORT (CL:FIND-SYMBOL I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*))) (* |;;| "If these other packages are around, grab their symbols") (LET (P S) (CL:WHEN (SETQ P (CL:FIND-PACKAGE "XP")) (CL:DOLIST (I (QUOTE ("*PRINT-PPRINT-DISPATCH*" "*PPRINT-RIGHT-MARGIN*" "*PPRINT-MISER-WIDTH*" "PPRINT-NEWLINE" "PPRINT-LOGICAL-BLOCK" "PPRINT-EXIT-IF-LIST-EXHAUSTED" "PPRINT-POP" "PPRINT-INDENT" "PPRINT-TAB" "PPRINT-FILL" "PPRINT-LINEAR" "PPRINT-TABULAR" "FORMATTER" "COPY-PPRINT-DISPATCH" "PPRINT-DISPATCH" "SET-PPRINT-DISPATCH"))) (SETQ S (CL:FIND-SYMBOL I P)) (IMPORT S *COMMON-LISP-PACKAGE*) (EXPORT S *COMMON-LISP-PACKAGE*))) (* |;;| "This will have to be changed somewhat as we change the CONDITIONS system to comply with CLtL2") (CL:WHEN (SETQ P (CL:FIND-PACKAGE "CONDITIONS")) (CL:UNUSE-PACKAGE *LISP-PACKAGE* P) (CL:USE-PACKAGE *COMMON-LISP-PACKAGE* P) (CL:DO-EXTERNAL-SYMBOLS (I P) (LET ((S (CL:FIND-SYMBOL (CL:SYMBOL-NAME I) *COMMON-LISP-PACKAGE*))) (IF S THEN (CL:SHADOWING-IMPORT I *COMMON-LISP-PACKAGE*) ELSE (IMPORT I *COMMON-LISP-PACKAGE*)) (EXPORT I *COMMON-LISP-PACKAGE*)))) (* |;;| "Finally, hose out the new COMMON-LISP symbols") (CL:DOLIST (I NEWCLSYMS) (EXPORT (CL:INTERN I *COMMON-LISP-PACKAGE*) *COMMON-LISP-PACKAGE*)) (FLIP-CL :COMMON-LISP))))
+
+(CL:DEFUN FLIP-CL (WHERE) (LET ((WHERE-WAS-IT (CL:FIND-PACKAGE "CL"))) (SETQ WHERE-WAS-IT (COND ((EQ WHERE-WAS-IT *COMMON-LISP-PACKAGE*) :COMMON-LISP) ((EQ WHERE-WAS-IT *LISP-PACKAGE*) :LISP) ((NULL WHERE-WAS-IT) :NOWHERE) (T (ERROR "CL nickname in odd package" WHERE-WAS-IT)))) (CL:ECASE WHERE (:LISP (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL) (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" (QUOTE ("CL")) "CL")) (:COMMON-LISP (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" (QUOTE ("CL")) "CL")) (:NOWHERE (CL:RENAME-PACKAGE *LISP-PACKAGE* "LISP" NIL NIL) (CL:RENAME-PACKAGE *COMMON-LISP-PACKAGE* "COMMON-LISP" NIL NIL))) WHERE-WAS-IT))
+
+(PUTPROPS COMMON-LISP-PACKAGE FILETYPE :COMPILE-FILE)
+(PUTPROPS COMMON-LISP-PACKAGE COPYRIGHT ("Venue Corporation" 1991 1992))
+(DECLARE\: DONTCOPY
+  (FILEMAP (NIL)))
+STOP

CLTL2/CONDITION-HIERARCHY

@@ -0,0 +1,136 @@
+(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE "XCL" (USE)))
+
(IL:FILECREATED "25-Oct-91 16:28:50" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY.;3|
 12064  
+
+      IL:|changes| IL:|to:|  (IL:VARS IL:CONDITION-HIERARCHYCOMS)
+
+      IL:|previous| IL:|date:| "30-Jul-91 15:14:18" 
+IL:|{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY.;2|)
+
+
+; Copyright (c) 1986, 1987, 1988, 1990, 1991 by Venue & Xerox Corporation.  All rights reserved.
+
+(IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHYCOMS)
+
+(IL:RPAQQ IL:CONDITION-HIERARCHYCOMS ((IL:STRUCTURES CONDITION SIMPLE-CONDITION WARNING SIMPLE-WARNING SERIOUS-CONDITION ERROR SIMPLE-ERROR ASSERTION-FAILED HASH-TABLE-FULL) (IL:STRUCTURES CELL-ERROR UNBOUND-VARIABLE UNDEFINED-FUNCTION ATTEMPT-TO-CHANGE-CONSTANT ATTEMPT-TO-RPLAC-NIL) (IL:FILES IL:CONDITION-HIERARCHY-SI IL:CONDITION-HIERARCHY-POST-SI) (IL:COMS (IL:FUNCTIONS IL:PRETTY-TYPE-NAME) (IL:STRUCTURES TYPE-ERROR SIMPLE-TYPE-ERROR TYPE-MISMATCH SYMBOL-AS-PATHNAME)) (IL:STRUCTURES CONTROL-ERROR PROGRAM-ERROR ILLEGAL-GO ILLEGAL-RETURN ILLEGAL-THROW BAD-PROCEED-CASE) (IL:STRUCTURES STREAM-ERROR STREAM-NOT-OPEN READ-ERROR SYMBOL-NAME-TOO-LONG END-OF-FILE) (IL:STRUCTURES STORAGE-CONDITION STACK-OVERFLOW CRITICAL-STORAGE-CONDITION STORAGE-EXHAUSTED SYMBOL-HT-FULL ARRAY-SPACE-FULL DATA-TYPES-EXHAUSTED) (IL:STRUCTURES DEVICE-ERROR SIMPLE-DEVICE-ERROR) (IL:STRUCTURES FILE-ERROR FILE-WONT-OPEN FS-RESOURCES-EXCEEDED FS-PROTECTION-VIOLATION FS-RENAMEFILE-SOURCE-COULDNT-DELETE) (IL:STRUCTURES ARITHMETIC-ERROR DIVISION-BY-ZERO FLOATING-POINT-OVERFLOW FLOATING-POINT-UNDERFLOW) (IL:STRUCTURES PATHNAME-ERROR FILE-NOT-FOUND INVALID-PATHNAME) (IL:STRUCTURES CL::PRINT-NOT-READABLE) (IL:FUNCTIONS SIMPLE-CONDITION-FORMAT-ARGUMENTS SIMPLE-CONDITION-FORMAT-STRING) (IL:FILES IL:CONDITION-HIERARCHY-IL) (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT) IL:CONDITION-HIERARCHY)))
+
+(DEFINE-CONDITION CONDITION NIL NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Condition ~S occurred." CONDITION))))
+
+(DEFINE-CONDITION SIMPLE-CONDITION (CONDITION) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-CONDITION-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-CONDITION-FORMAT-STRING CONDITION) (%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION WARNING (CONDITION) (CONDITION) (:REPORT (LAMBDA (C S) (FORMAT S "Warning: ~A" (WARNING-CONDITION S)))))
+
+(DEFINE-CONDITION SIMPLE-WARNING (WARNING) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-WARNING-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-WARNING-FORMAT-STRING CONDITION) (%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION SERIOUS-CONDITION (CONDITION) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Serious condition ~S occurred." (TYPE-OF CONDITION)))))
+
+(DEFINE-CONDITION ERROR (SERIOUS-CONDITION) NIL)
+
+(DEFINE-CONDITION SIMPLE-ERROR (ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-ERROR-") (:REPORT (LAMBDA (CONDITION STREAM) (APPLY (QUOTE FORMAT) STREAM (%SIMPLE-ERROR-FORMAT-STRING CONDITION) (%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION ASSERTION-FAILED (SIMPLE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (APPLY (QUOTE FORMAT) T (OR (ASSERTION-FAILED-FORMAT-STRING CONDITION) "Assertion failed.") (ASSERTION-FAILED-FORMAT-ARGUMENTS CONDITION)))))
+
+(DEFINE-CONDITION HASH-TABLE-FULL (ERROR) (TABLE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Hash table full: ~S" (HASH-TABLE-FULL-TABLE CONDITION)))))
+
+(DEFINE-CONDITION CELL-ERROR (ERROR) (NAME))
+
+(DEFINE-CONDITION UNBOUND-VARIABLE (CELL-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "~S is an unbound variable." (UNBOUND-VARIABLE-NAME C)))))
+
+(DEFINE-CONDITION UNDEFINED-FUNCTION (CELL-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "~S is an undefined function." (UNDEFINED-FUNCTION-NAME C)))))
+
+(DEFINE-CONDITION ATTEMPT-TO-CHANGE-CONSTANT (CELL-ERROR) NIL)
+
+(DEFINE-CONDITION ATTEMPT-TO-RPLAC-NIL (ATTEMPT-TO-CHANGE-CONSTANT) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Attempt to rplac NIL with ~S" (ATTEMPT-TO-RPLAC-NIL-NAME CONDITION)))))
+
+(IL:FILESLOAD IL:CONDITION-HIERARCHY-SI IL:CONDITION-HIERARCHY-POST-SI)
+
+(DEFUN IL:PRETTY-TYPE-NAME (IL:TYPESPEC) (IL:IF (EQ (CAR (IL:LISTP IL:TYPESPEC)) (QUOTE OR)) IL:THEN (LET ((IL:TYPES (IL:SUBSET (CDR IL:TYPESPEC) (IL:FUNCTION (IL:LAMBDA (IL:NAME) (NOT (IL:SOME (CDR IL:TYPESPEC) (IL:FUNCTION (IL:LAMBDA (IL:OTHER) (AND (IL:NEQ IL:OTHER IL:NAME) (SUBTYPEP IL:NAME IL:OTHER))))))))))) (IL:IF (IL:EQUAL (IL:SORT IL:TYPES) (QUOTE (COMPLEX FLOAT INTEGER RATIO))) IL:THEN "a number" IL:ELSE (IL:CONCATLIST (CDR (IL:FOR IL:X IL:IN IL:TYPES IL:JOIN (LIST " or " (IL:PRETTY-TYPE-NAME IL:X))))))) IL:ELSE (LET (IL:DOC) (IF (AND (SYMBOLP IL:TYPESPEC) (IL:SETQ IL:DOC (DOCUMENTATION IL:TYPESPEC (QUOTE TYPE)))) IL:DOC (IL:CONCAT "a " IL:TYPESPEC)))))
+
+(DEFINE-CONDITION TYPE-ERROR (ERROR) (EXPECTED-TYPE DATUM) (:REPORT (LAMBDA (C S) (FORMAT S "Arg not ~A~&~S" (IL:PRETTY-TYPE-NAME (TYPE-ERROR-EXPECTED-TYPE C)) (TYPE-ERROR-DATUM C)))))
+
+(DEFINE-CONDITION SIMPLE-TYPE-ERROR (IL:* IL:|;;;| "This is a pretty worthless type to have around.") (TYPE-ERROR) (FORMAT-STRING FORMAT-ARGUMENTS) (:CONC-NAME "%SIMPLE-TYPE-ERROR-") (:REPORT (LAMBDA (C S) (APPLY (QUOTE FORMAT) S (%SIMPLE-TYPE-ERROR-FORMAT-STRING C) (%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS C)))))
+
+(DEFINE-CONDITION TYPE-MISMATCH (TYPE-ERROR) (NAME VALUE MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (IF (EQL (TYPE-MISMATCH-NAME CONDITION) (TYPE-MISMATCH-VALUE CONDITION)) (FORMAT T "~S is not ~A." (TYPE-MISMATCH-VALUE CONDITION) (OR (TYPE-MISMATCH-MESSAGE CONDITION) (IL:PRETTY-TYPE-NAME (TYPE-MISMATCH-EXPECTED-TYPE CONDITION)))) (FORMAT T "The value of ~S, ~S, is not ~A." (TYPE-MISMATCH-NAME CONDITION) (TYPE-MISMATCH-VALUE CONDITION) (OR (TYPE-MISMATCH-MESSAGE CONDITION) (IL:PRETTY-TYPE-NAME (TYPE-MISMATCH-EXPECTED-TYPE CONDITION))))))))
+
+(DEFINE-CONDITION SYMBOL-AS-PATHNAME (TYPE-ERROR) (SYMBOL WHERE MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (IF (SYMBOL-AS-PATHNAME-MESSAGE CONDITION) (FORMAT T (SYMBOL-AS-PATHNAME-MESSAGE CONDITION) (SYMBOL-AS-PATHNAME-SYMBOL CONDITION)) (FORMAT T "~a: symbol ~s used as pathname" (SYMBOL-AS-PATHNAME-WHERE CONDITION) (SYMBOL-AS-PATHNAME-SYMBOL CONDITION))))))
+
+(DEFINE-CONDITION CONTROL-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION PROGRAM-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION ILLEGAL-GO (PROGRAM-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "GO to a nonexistent tag: ~S." (ILLEGAL-GO-TAG CONDITION)))))
+
+(DEFINE-CONDITION ILLEGAL-RETURN (PROGRAM-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "RETURN to nonexistent block: ~S." (ILLEGAL-RETURN-TAG CONDITION)))))
+
+(DEFINE-CONDITION ILLEGAL-THROW (CONTROL-ERROR) (TAG) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Tag for THROW not found: ~S." (ILLEGAL-THROW-TAG CONDITION)))))
+
+(DEFINE-CONDITION BAD-PROCEED-CASE (CONTROL-ERROR) (NAME) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Proceed case ~S is not currently active." (BAD-PROCEED-CASE-NAME CONDITION)))))
+
+(DEFINE-CONDITION STREAM-ERROR (ERROR) (STREAM) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Stream error on ~S." (STREAM-ERROR-STREAM CONDITION)))))
+
+(DEFINE-CONDITION STREAM-NOT-OPEN (STREAM-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Stream not open: ~S" (STREAM-NOT-OPEN-STREAM CONDITION)))))
+
+(DEFINE-CONDITION READ-ERROR (ERROR) NIL)
+
+(DEFINE-CONDITION SYMBOL-NAME-TOO-LONG (READ-ERROR) NIL (:REPORT "Symbol name too long"))
+
+(DEFINE-CONDITION END-OF-FILE (STREAM-ERROR) NIL (:REPORT (LAMBDA (CONDITION STREAM) (FORMAT STREAM "End of file ~S" (END-OF-FILE-STREAM CONDITION)))))
+
+(DEFINE-CONDITION STORAGE-CONDITION (SERIOUS-CONDITION) NIL)
+
+(DEFINE-CONDITION STACK-OVERFLOW (STORAGE-CONDITION) NIL (:REPORT "Stack overflow"))
+
+(DEFINE-CONDITION CRITICAL-STORAGE-CONDITION (STORAGE-CONDITION) NIL)
+
+(DEFINE-CONDITION STORAGE-EXHAUSTED (CRITICAL-STORAGE-CONDITION) NIL)
+
+(DEFINE-CONDITION SYMBOL-HT-FULL (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "Symbol hash table full"))
+
+(DEFINE-CONDITION ARRAY-SPACE-FULL (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "Array space full"))
+
+(DEFINE-CONDITION DATA-TYPES-EXHAUSTED (CRITICAL-STORAGE-CONDITION) NIL (:REPORT "No more data types available"))
+
+(DEFINE-CONDITION DEVICE-ERROR (SERIOUS-CONDITION) (DEVICE))
+
+(DEFINE-CONDITION SIMPLE-DEVICE-ERROR (DEVICE-ERROR) (MESSAGE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Device error: ~A" (SIMPLE-DEVICE-ERROR-MESSAGE CONDITION)))))
+
+(DEFINE-CONDITION FILE-ERROR (ERROR) (PATHNAME))
+
+(DEFINE-CONDITION FILE-WONT-OPEN (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "File won't open: ~A" (FILE-WONT-OPEN-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION FS-RESOURCES-EXCEEDED (FILE-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "File system resources exceeded: ~A" (FS-RESOURCES-EXCEEDED-PATHNAME C)))))
+
+(DEFINE-CONDITION FS-PROTECTION-VIOLATION (FILE-ERROR) NIL (:REPORT (LAMBDA (C S) (FORMAT S "Protection violation: ~A" (FILE-ERROR-PATHNAME C)))))
+
+(DEFINE-CONDITION FS-RENAMEFILE-SOURCE-COULDNT-DELETE (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Couldn't delete the source file: ~A" (FS-RENAMEFILE-SOURCE-COULDNT-DELETE-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION ARITHMETIC-ERROR (ERROR) (OPERATION OPERANDS) (:REPORT (LAMBDA (C S) (FORMAT S "Arithmetic error during (~S~{ ~S~})" (ARITHMETIC-ERROR-OPERATION C) (ARITHMETIC-ERROR-OPERANDS C)))))
+
+(DEFINE-CONDITION DIVISION-BY-ZERO (ARITHMETIC-ERROR) NIL (:REPORT "Attempt to divide by zero."))
+
+(DEFINE-CONDITION FLOATING-POINT-OVERFLOW (ARITHMETIC-ERROR) NIL (:REPORT "Floating point overflow."))
+
+(DEFINE-CONDITION FLOATING-POINT-UNDERFLOW (ARITHMETIC-ERROR) NIL (:REPORT "Floating point underflow."))
+
+(DEFINE-CONDITION PATHNAME-ERROR (ERROR) (PATHNAME))
+
+(DEFINE-CONDITION FILE-NOT-FOUND (FILE-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "File not found: ~A" (FILE-NOT-FOUND-PATHNAME CONDITION)))) (:HANDLE (LAMBDA (CONDITION) (COND ((BOUNDP (QUOTE IL:ERRORPOS)) (LET ((NEWNAME (IL:SPELLFILE (IL:ROOTFILENAME (FILE-NOT-FOUND-PATHNAME CONDITION)) NIL IL:NOFILESPELLFLG))) (COND (NEWNAME (IL:ENVAPPLY (IL:STKNAME IL:ERRORPOS) (IL:SUBST NEWNAME (FILE-NOT-FOUND-PATHNAME CONDITION) (MAPCAR (FUNCTION (LAMBDA (X) (IF (PATHNAMEP X) (NAMESTRING X) X))) (IL:STKARGS IL:ERRORPOS))) (IL:STKNTH -1 IL:ERRORPOS IL:ERRORPOS) IL:ERRORPOS T T)))))))))
+
+(DEFINE-CONDITION INVALID-PATHNAME (PATHNAME-ERROR) NIL (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (FORMAT T "Invalid pathname: ~A" (INVALID-PATHNAME-PATHNAME CONDITION)))))
+
+(DEFINE-CONDITION CL::PRINT-NOT-READABLE (ERROR) (THING WHERE) (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*) (LET ((CL:*PRINT-READABLY* NIL)) (FORMAT T "~S cannot be printed readably~@[ by ~S~]" (CL::PRINT-NOT-READABLE-THING CONDITION) (CL::PRINT-NOT-READABLE-WHERE CONDITION))))))
+
+(DEFUN SIMPLE-CONDITION-FORMAT-ARGUMENTS (CONDITION) (ETYPECASE CONDITION (SIMPLE-ERROR (%SIMPLE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-TYPE-ERROR (%SIMPLE-TYPE-ERROR-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-CONDITION (%SIMPLE-CONDITION-FORMAT-ARGUMENTS CONDITION)) (SIMPLE-WARNING (%SIMPLE-WARNING-FORMAT-ARGUMENTS CONDITION))))
+
+(DEFUN SIMPLE-CONDITION-FORMAT-STRING (CONDITION) (ETYPECASE CONDITION (SIMPLE-ERROR (%SIMPLE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-TYPE-ERROR (%SIMPLE-TYPE-ERROR-FORMAT-STRING CONDITION)) (SIMPLE-CONDITION (%SIMPLE-CONDITION-FORMAT-STRING CONDITION)) (SIMPLE-WARNING (%SIMPLE-WARNING-FORMAT-STRING CONDITION))))
+
+(IL:FILESLOAD IL:CONDITION-HIERARCHY-IL)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:FILETYPE COMPILE-FILE)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE "XCL" (:USE))))
+(IL:PUTPROPS IL:CONDITION-HIERARCHY IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991
+))
+(IL:DECLARE\: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP

CLTL2/CONDITION-HIERARCHY-SI

@@ -0,0 +1,56 @@
+(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "SYSTEM")
+
(IL:FILECREATED "16-May-90 15:05:52" 
+IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;2
 2452   
+
+      IL:changes IL:to%:  (IL:VARS IL:CONDITION-HIERARCHY-SICOMS)
+
+      IL:previous IL:date%: "11-Jan-88 18:43:35" 
+IL:{DSK}<usr>local>lde>lispcore>sources>CONDITION-HIERARCHY-SI.;1)
+
+
+(IL:* ; "
+Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation.  All rights reserved.
+")
+
+(IL:PRETTYCOMPRINT IL:CONDITION-HIERARCHY-SICOMS)
+
+(IL:RPAQQ IL:CONDITION-HIERARCHY-SICOMS
 ((IL:STRUCTURES DEBUGGER-EVAL-ABORTED)
+                                             (IL:STRUCTURES NO-PROCEED-TEST)
+                                             (IL:STRUCTURES BREAKPOINT INTERRUPT REVERT)
+                                             (IL:PROP (IL:FILETYPE IL:MAKEFILE-ENVIRONMENT)
+                                                    IL:CONDITION-HIERARCHY-SI)))
+
+(XCL:DEFINE-CONDITION DEBUGGER-EVAL-ABORTED
 (XCL:CONDITION)
+   (CONDITION)
+   (:REPORT "DEBUGGER-EVAL was aborted."))
+
+(XCL:DEFINE-CONDITION NO-PROCEED-TEST
 (XCL:UNDEFINED-FUNCTION)
+   NIL
+   (:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT T "No test specified for proceed case: ~S." NAME))))
+
+(XCL:DEFINE-CONDITION BREAKPOINT
 (XCL:SERIOUS-CONDITION)
+   (FUNCTION)
+   [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (IF (CONSP (BREAKPOINT-FUNCTION CONDITION))
+                       (FORMAT T "Breakpoint at ~S, called from ~S." (FIRST (BREAKPOINT-FUNCTION
+                                                                             CONDITION))
+                              (THIRD (BREAKPOINT-FUNCTION CONDITION)))
+                       (FORMAT T "Breakpoint at ~S." (BREAKPOINT-FUNCTION CONDITION)))])
+
+(XCL:DEFINE-CONDITION INTERRUPT
 (BREAKPOINT)
+   NIL
+   [:REPORT (LAMBDA (CONDITION *STANDARD-OUTPUT*)
+                   (FORMAT T "Interrupt below ~S." (INTERRUPT-FUNCTION CONDITION])
+
+(XCL:DEFINE-CONDITION REVERT
 (BREAKPOINT)
+   NIL)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI
 IL:FILETYPE
 IL:COMPILE-FILE)
+
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI
 IL:MAKEFILE-ENVIRONMENT
 (:READTABLE "INTERLISP" 
+                                                                              :PACKAGE "SYSTEM"))
+(IL:PUTPROPS IL:CONDITION-HIERARCHY-SI IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990))
+(IL:DECLARE%: IL:DONTCOPY
+  (IL:FILEMAP (NIL)))
+IL:STOP