LMFL#!C(:HOST "SYS" :BACKUP-DATE 2760032861. :SYSTEM-TYPE :LOGICAL :VERSION 6. :TYPE "LISP" :NAME "TI-PATCHES" :DIRECTORY ("REL3-PUBLIC" "PUBLIC" "PCL") :SOURCE-PATTERN "( :DIRECTORY (\"REL3-PUBLIC\") :NAME :WILD :TYPE :WILD :VERSION :NEWEST)" :CHARACTERS T :NOT-BACKED-UP T :CREATION-DATE 2756388248. :AUTHOR "REL3" :LENGTH-IN-BYTES 5645. :LENGTH-IN-BLOCKS 6. :BYTE-SIZE 8.)                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                         ;;;    -*- Mode:Common-Lisp; Package:Compiler; Base:10;Patch-file: t -*-(DEFUN EVAL-FOR-TARGET ( FORM &OPTIONAL ENVIRONMENT &AUX TM)  "Evaluate FORM, using definitions from the target machine's environment."  ;;  3/08/85 - Check FILE-CONSTANTS-LIST even for host machine.  ;;  2/19/86 - Use target definitions of macros and functions;  ;;upgrade to handle local variables correctly.  ;;  2/20/86 - Fix handling of special variable bindings.  ;;  2/22/86 - Fix to evaluate ADVISE and SI:%MAKE-POINTER in host environment.  ;;  3/04/86 - Make sure *POSSIBLE-SPECIAL-BINDINGS* is bound to T when evaluating  ;;special forms LET, DO, PROG, etc.  ;;  3/19/86 - Treat PROGV, PROGW, and MULTIPLE-VALUE-BIND like LET.  ;;  4/24/86 - Remove use of ARGS-INFO for VM2.  ;;  8/12/86 - Override host definition of FUNCTION to avoid problem of  ;;returning a closure object when it should be (MACRO . closure) instead.  ;; 11/18/86 - Remove above FUNCTION hack for release 3.  ;;  3/07/87 - Don't do special handling for MAKE-ARRAY unless cross-compiling.  ;;  4/28/87 PHD - Fix for local macros. [SPR 4655]  (COND ((NULL FORM) NIL)((SYMBOLP FORM) (IF (KEYWORDP FORM) ; keywords eval to themselves     FORM   (PROGN     (WHEN (COMMON-LISP-ON-P)       ;; The following adapted from SI:EVAL1-SYMBOL-LOOKUP        ;; first search the lexical and then the global       (LET ((vcell (LOCF (SYMBOL-VALUE FORM)))) ;; fetch the value cell address (DO ((tailenv (CAR ENVIRONMENT) (CDR tailenv)) ;; search each frame      slot)     ((ATOM tailenv) ) ;; if no binding in lexical - search global   (SETQ slot (GET-LEXICAL-VALUE-CELL (CAR tailenv) vcell))   (WHEN slot   ; return value of symbol in frame     (RETURN-FROM EVAL-FOR-TARGET (CAR slot))))))     (LET (( TEMP (ASSOC FORM FILE-CONSTANTS-LIST :TEST #'EQ) ))       (IF TEMP    ;; Value defined by a DEFCONSTANT earlier in the current   ;; file being compiled.   (CDR TEMP) (IF (AND *POSSIBLE-SPECIAL-BINDINGS*  (BOUNDP FORM)  (OR (NULL (GET FORM TARGET-PROCESSOR))      (BOUND-SYMBOL-P FORM))  (NOT (GET-FOR-TARGET FORM 'SYSTEM-CONSTANT)))     ;; Looks like there has been a special binding, use the current value.     (SYMBOL-VALUE FORM)    ;; Else, get global target value.   (SYMEVAL-FOR-TARGET FORM)   ))))))((ATOM FORM) FORM)((AND (EQ (FIRST FORM) 'QUOTE) (= (LENGTH FORM) 2)) (SECOND FORM))((AND (EQ TARGET-PROCESSOR HOST-PROCESSOR)      (NULL FILE-CONSTANTS-LIST)      (NULL FILE-LOCAL-DECLARATIONS)) ;; no need for any special handling. (SI:EVAL1 FORM))((OR (AND (NEQ TARGET-PROCESSOR HOST-PROCESSOR)  (MEMBER (FIRST FORM)  '(SI::ENCAPSULATION-LET; for ADVISE in LOAD-FOR-TARGET     %MAKE-POINTER; must evaluate data type for host     #-Elroy DEFUN; new DEFUN can't handle old-style property fspecs     MAKE-ARRAY MAKE-SYMBOL-IN-AREA; need to evaluate area number for host     )  :TEST #'EQ))     ) ; in debugger ;; need to evaluate in host environment (SI:EVAL1 FORM))((EQ (FIRST FORM) 'SETQ) (LET (( VALUE NIL ))   (DO ((ARGS (REST FORM) (CDDR ARGS)))       ((NULL ARGS))     (LET (( SYMBOL (FIRST ARGS) ))       (SETQ VALUE (EVAL-FOR-TARGET (SECOND ARGS) ENVIRONMENT) )       (BLOCK SET (UNLESS (ZETALISP-ON-P)   ;; The following adapted from SI:INTERPRETER-SET    (LET ((vcaddress (LOCF (SYMBOL-VALUE symbol)))) ; get value cell address     (DO ((tail (CAR environment) (CDR tail))) ((ATOM tail))       (LET ((slot (GET-LEXICAL-VALUE-CELL (CAR tail) vcaddress))) (IF slot     (RETURN-FROM SET (SETF (CAR slot) value))))))) (IF (AND *POSSIBLE-SPECIAL-BINDINGS*  (BOUNDP SYMBOL)  (OR (NULL (GET SYMBOL TARGET-PROCESSOR))      (BOUND-SYMBOL-P SYMBOL))  (NOT (GET SYMBOL 'SYSTEM-CONSTANT)))     ;; Looks like there has been a special binding, replace the current value.     (SET SYMBOL VALUE)   (SET-FOR-TARGET SYMBOL VALUE) ) )       ) )   VALUE ) )((SETQ TM (GET (FIRST FORM) 'EVAL-FOR-TARGET)) (LET ((*EVALHOOK* #'EVAL-FOR-TARGET))   (SI:EVAL1 (IF (EQ TM (FIRST FORM)) FORM       (CONS TM (REST FORM)))     T) ) )((EQ (FIRST FORM) 'DEFPROP) (APPLY #'PUTPROP-FOR-TARGET (REST FORM)))((EQ (FIRST FORM) 'FUNCTION) (FUNCTION-FOR-TARGET (SECOND FORM) (SECOND ENVIRONMENT)))(T (LET (( DEF (AND (ATOM (FIRST FORM))    (NOT (MEMBER (FIRST FORM) '(LET LET* DO DO* PROG PROG* DO-NAMED DO-NAMED*   LET-IF COMPILER-LET PROGV PROGW MULTIPLE-VALUE-BIND) :TEST #'EQ) )    (or (WHEN (COMMON-LISP-ON-P)      ;; The following adapted from SI:EVAL1-SYMBOL-LOOKUP       ;; first search the lexical and then the global      (LET ((vcell (LOCF (SYMBOL-function  (car FOrM))))) (DO ((tailenv (CAdR ENVIRONMENT) (CDR tailenv))      slot)    ((ATOM tailenv) )   (SETQ slot (GET-LOCATION-OR-NIL (LOCF (car tailenv)) vcell))  (WHEN slot   ; return value of symbol in frame    (RETURN  (CAR slot))))))    (DECLARED-DEFINITION (FIRST FORM))) )))     (COND ((NULL DEF)    (LET (( *EVALHOOK* #'EVAL-FOR-TARGET )  ( *POSSIBLE-SPECIAL-BINDINGS* T ))      (SI:EVAL1 FORM T) ))   ((EQ (CAR-SAFE DEF) 'MACRO)    (EVAL-FOR-TARGET (LET (( *EVALHOOK* #'EVAL-FOR-TARGET ))       (FUNCALL (CDR DEF) FORM  ENVIRONMENT) )     ENVIRONMENT))   (T (LET (( *EVALHOOK* #'EVAL-FOR-TARGET )    ( *POSSIBLE-SPECIAL-BINDINGS* T ))(SI:EVAL1 (CONS DEF (REST FORM)) T) )))     ))))(setf (get 'function 'si:type-predicate ) 'functionp) (PROCLAIM '(NOTINLINE NIL))ith-slots ((obj :prefix obj-))      (setq obj-x 1            obj-y 2)))  (and (equal '(nil nil) (foo (make 'test-class-1)))       (equal '(1 2) (foo (make 'test-class-1 :x 1 :y 2)))       (let ((foo (make 'test-class-1)))         (bar foo)         (and (equal (get-slot foo 'x) 1)              (equal (get-slot foo 'y) 2)))))(do-test "Simple with-slots test (:use-slot-value t)."    (defmethod foo ((obj test-class-1))    (with-slots ((obj :use-slot-value t))      (list x y)))  (de