(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP") (FILECREATED " 1-Nov-88 19:29:03" {ERIS}<LISPCORE>PATCHES>AR-10922-PATCH.\;1 26117 |changes| |to:| (VARS AR-10922-PATCHCOMS)) ; Copyright (c) 1988 by ENVOS Corporation. All rights reserved. (PRETTYCOMPRINT AR-10922-PATCHCOMS) (RPAQQ AR-10922-PATCHCOMS ( (* |;;| "Patch file AR-10922-PATCH. Contains fixes for the AR(s) (10922).") (ADDVARS (*FEATURES* :AR-10922)) (FUNCTIONS D-ASSEM::ASSEMBLE-CODE) (PROP FILETYPE AR-10922-PATCH))) (* |;;| "Patch file AR-10922-PATCH. Contains fixes for the AR(s) (10922).") (ADDTOVAR *FEATURES* :AR-10922) (CL:DEFUN D-ASSEM::ASSEMBLE-CODE (D-ASSEM::LAP-CODE D-ASSEM::DEPTH D-ASSEM::BINDING-DEPTH) (* |;;;| "Translate LAP code into D-machine bytecodes.") (CL:DO ((D-ASSEM::TAIL D-ASSEM::LAP-CODE (CDR D-ASSEM::TAIL)) D-ASSEM::INST) ((CL:ENDP D-ASSEM::TAIL)) (CL:SETQ D-ASSEM::INST (CL:FIRST D-ASSEM::TAIL)) (CL:MACROLET ((D-ASSEM::INCR (D-ASSEM::VAR &OPTIONAL (D-ASSEM::DELTA 1)) `(AND ,D-ASSEM::VAR (CL:SETQ ,D-ASSEM::VAR (+ ,D-ASSEM::VAR ,D-ASSEM::DELTA)))) (D-ASSEM::DECR (D-ASSEM::VAR &OPTIONAL (D-ASSEM::DELTA 1)) `(AND ,D-ASSEM::VAR (CL:SETQ ,D-ASSEM::VAR (- ,D-ASSEM::VAR ,D-ASSEM::DELTA))))) (CL:ECASE (CAR D-ASSEM::INST) ((:VAR) (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::REF-VAR (CL:SECOND D-ASSEM::INST))) (D-ASSEM::INCR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :VAR)) ((:VAR←) (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::STORE-VAR (CL:SECOND D-ASSEM::INST) (COND ((EQ ':POP (CL:FIRST (CL:SECOND D-ASSEM::TAIL ))) (CL:SETQ D-ASSEM::TAIL (CDR D-ASSEM::TAIL)) (D-ASSEM::DECR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :VAR←) T) (T NIL))))) ((:COPY) (D-ASSEM::EMIT-BYTE 'COPY) (D-ASSEM::INCR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :COPY)) ((:SWAP) (D-ASSEM::EMIT-BYTE 'SWAP)) ((:CONST) (LET* ((D-ASSEM::VALUE (CL:SECOND D-ASSEM::INST)) (D-ASSEM::LOOKUP (CL:ASSOC D-ASSEM::VALUE D-ASSEM::+CONSTANT-OPCODES+))) (COND ((NOT (NULL D-ASSEM::LOOKUP)) (D-ASSEM::EMIT-BYTE (CDR D-ASSEM::LOOKUP))) ((CL:SYMBOLP D-ASSEM::VALUE) (D-ASSEM::EMIT-BYTE-LIST `(ACONST (:SYM ,D-ASSEM::VALUE)))) ((CL:INTEGERP D-ASSEM::VALUE) (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::PUSH-INTEGER D-ASSEM::VALUE))) (T (D-ASSEM::EMIT-BYTE-LIST `(GCONST (:LIT ,D-ASSEM::VALUE)))))) (D-ASSEM::INCR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :CONST)) ((:LAMBDA) (LET ((D-ASSEM::DLAMBDA (CL:SECOND D-ASSEM::INST)) (D-ASSEM::LAMBDA-LEVEL (CL:THIRD D-ASSEM::INST))) (COND ((AND NIL (CL:ZEROP D-ASSEM::LAMBDA-LEVEL)) (* \; "We used to do something different for lambdas with empty environments.") (D-ASSEM::EMIT-BYTE-LIST `(GCONST (:LAMBDA 0 ,D-ASSEM::DLAMBDA)))) (T (* |;;| "This will need to be a closure. Find our best hunk for it and construct a closure object around it and the lambda.") (D-ASSEM::EMIT-BYTE-LIST `(SICX (:TYPE COMPILED-CLOSURE) CREATECELL GCONST (:LAMBDA ,D-ASSEM::LAMBDA-LEVEL ,D-ASSEM::DLAMBDA) RPLPTR.N 0 ,@(AND (NOT (CL:ZEROP D-ASSEM::LAMBDA-LEVEL)) `(,@(D-ASSEM::FETCH-HUNK D-ASSEM::LAMBDA-LEVEL) RPLPTR.N 2)))))) (D-ASSEM::INCR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :LAMBDA))) ((:POP) (D-ASSEM::EMIT-BYTE 'POP) (D-ASSEM::DECR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :POP)) ((:NOTE-STACK) (* \; "Now a no-op; used during stack analysis.") ) ((:SET-STACK :DSET-STACK) (CL:FLET ((D-ASSEM::EMIT-UNWIND (D-ASSEM::DESIRED-DEPTH D-ASSEM::SAVE-TOS?) (D-ASSEM::EMIT-BYTE-LIST `(UNWIND (:UNWIND ,D-ASSEM::DESIRED-DEPTH) ,(CL:IF D-ASSEM::SAVE-TOS? 1 0))))) (LET* ((D-ASSEM::SAVE-TOS? (EQ (CL:FIRST D-ASSEM::INST) :SET-STACK)) (D-ASSEM::LOOKUP (CL:GETHASH (CL:SECOND D-ASSEM::INST) D-ASSEM::*STACK-ENV*)) (D-ASSEM::DESIRED-DEPTH (CL:FIRST D-ASSEM::LOOKUP)) (D-ASSEM::DESIRED-BINDING-DEPTH (CL:MAPCAR 'CDR (CL:SECOND D-ASSEM::LOOKUP)))) (COND ((NULL D-ASSEM::DEPTH) (* |;;| "We don't know where we are: use UNWIND.") (D-ASSEM::EMIT-UNWIND D-ASSEM::DESIRED-DEPTH D-ASSEM::SAVE-TOS?) (CL:SETQ D-ASSEM::DEPTH D-ASSEM::DESIRED-DEPTH D-ASSEM::BINDING-DEPTH D-ASSEM::DESIRED-BINDING-DEPTH)) ((EQ (CL:FIRST D-ASSEM::BINDING-DEPTH) (CL:FIRST D-ASSEM::DESIRED-BINDING-DEPTH)) (* |;;| "There are no intervening binds, so we can just pop.") (CL:WHEN D-ASSEM::SAVE-TOS? (CL:DECF D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :SET-STACK)) (LET ((D-ASSEM::ADJUSTMENT (- D-ASSEM::DEPTH D-ASSEM::DESIRED-DEPTH))) (CL:IF (MINUSP D-ASSEM::ADJUSTMENT) (HELP "POP.N stack adjustment negative: " D-ASSEM::ADJUSTMENT)) (CASE D-ASSEM::ADJUSTMENT ((0) ) ((1) (CL:IF D-ASSEM::SAVE-TOS? (D-ASSEM::EMIT-BYTE 'SWAP)) (D-ASSEM::EMIT-BYTE 'POP)) (CL:OTHERWISE (CL:IF D-ASSEM::SAVE-TOS? (CL:IF (<= D-ASSEM::ADJUSTMENT 128) (* |;;| "STORE.N can only be used for distances less than this limit.") (D-ASSEM::EMIT-BYTE-LIST `(STORE.N ,(CL:* 2 (CL:1- D-ASSEM::ADJUSTMENT)) POP.N ,(CL:1- D-ASSEM::ADJUSTMENT))) (D-ASSEM::EMIT-UNWIND D-ASSEM::DESIRED-DEPTH T)) (CL:IF (<= D-ASSEM::ADJUSTMENT 256) (* |;;| "POP.N can only be used for disatnces less than this limit.") (D-ASSEM::EMIT-BYTE-LIST `(POP.N ,(CL:1- D-ASSEM::ADJUSTMENT ))) (D-ASSEM::EMIT-UNWIND D-ASSEM::DESIRED-DEPTH NIL))))) (CL:SETQ D-ASSEM::DEPTH D-ASSEM::DESIRED-DEPTH))) ((AND (CL:EQUAL (CL:REST D-ASSEM::BINDING-DEPTH) D-ASSEM::DESIRED-BINDING-DEPTH) (EQL D-ASSEM::DESIRED-DEPTH (CL:FIRST D-ASSEM::DESIRED-BINDING-DEPTH))) (* |;;| "There is only one bind mark in the way - use UNBIND") (D-ASSEM::EMIT-BYTE (CL:IF D-ASSEM::SAVE-TOS? 'UNBIND 'DUNBIND)) (CL:SETQ D-ASSEM::DEPTH (CL:POP D-ASSEM::BINDING-DEPTH)) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :|pop-of-binding-stack|)) (T (* |;;| "Use UNWIND in all other cases.") (D-ASSEM::EMIT-UNWIND D-ASSEM::DESIRED-DEPTH D-ASSEM::SAVE-TOS?) (CL:SETQ D-ASSEM::DEPTH D-ASSEM::DESIRED-DEPTH D-ASSEM::BINDING-DEPTH D-ASSEM::DESIRED-BINDING-DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :SET-STACK-USING-UNWIND))) (CL:WHEN D-ASSEM::SAVE-TOS? (CL:INCF D-ASSEM::DEPTH))))) ((:BIND) (CL:LABELS ((D-ASSEM::DO-BIND (D-ASSEM::NUM-VALUES D-ASSEM::NUM-NILS D-ASSEM::STARTING-SLOT) (COND ((> D-ASSEM::NUM-VALUES 15) (COMPILER:ASSEMBLER-ERROR "Too many non-NIL values bound in a single :BIND: ~S. Limit is 15." D-ASSEM::NUM-VALUES)) ((> D-ASSEM::NUM-NILS 15) (D-ASSEM::DO-BIND D-ASSEM::NUM-VALUES 15 D-ASSEM::STARTING-SLOT) (D-ASSEM::DO-BIND 0 (- D-ASSEM::NUM-NILS 15) (+ D-ASSEM::STARTING-SLOT D-ASSEM::NUM-VALUES 15))) (T (D-ASSEM::EMIT-BYTE-LIST `(BIND ,(+ (LLSH D-ASSEM::NUM-NILS 4) D-ASSEM::NUM-VALUES) ,(CL:1- (+ D-ASSEM::STARTING-SLOT D-ASSEM::NUM-VALUES D-ASSEM::NUM-NILS)))) (D-ASSEM::INCR D-ASSEM::DEPTH))))) (LET* ((CL:VALUES (CL:SECOND D-ASSEM::INST)) (D-ASSEM::NUM-VALUES (CL:LENGTH CL:VALUES)) (D-ASSEM::NILS (CL:THIRD D-ASSEM::INST)) (D-ASSEM::NUM-NILS (CL:LENGTH D-ASSEM::NILS))) (D-ASSEM::DECR D-ASSEM::DEPTH D-ASSEM::NUM-VALUES) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :BIND) (CL:PUSH D-ASSEM::DEPTH D-ASSEM::BINDING-DEPTH) (D-ASSEM::DO-BIND D-ASSEM::NUM-VALUES D-ASSEM::NUM-NILS (COND (CL:VALUES (D-ASSEM::DVAR-SLOT (CAR CL:VALUES))) (D-ASSEM::NILS (D-ASSEM::DVAR-SLOT (CAR D-ASSEM::NILS))) (T 1)))))) ((:UNBIND :DUNBIND) (LET ((BYTE (CASE (CL:FIRST D-ASSEM::INST) (:UNBIND 'UNBIND) (:DUNBIND 'DUNBIND)))) (CL:DOTIMES (D-ASSEM::I (CL:FLOOR (+ (CL:SECOND D-ASSEM::INST) (CL:THIRD D-ASSEM::INST) 14) 15)) (D-ASSEM::EMIT-BYTE BYTE))) (CL:SETQ D-ASSEM::DEPTH (CL:POP D-ASSEM::BINDING-DEPTH)) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :UNBIND) (CL:IF (EQ (CL:FIRST D-ASSEM::INST) ':UNBIND) (D-ASSEM::INCR D-ASSEM::DEPTH))) ((:TAG) (D-ASSEM::EMIT-BYTE `(:TAG ,(CL:SECOND D-ASSEM::INST))) (LET ((D-ASSEM::STACK-DEPTH (D-ASSEM::DTAG-STACK-DEPTH (CL:SECOND D-ASSEM::INST)))) (CL:SETQ D-ASSEM::DEPTH (CDR D-ASSEM::STACK-DEPTH)) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :TAG) (CL:SETQ D-ASSEM::BINDING-DEPTH (CL:MAPCAR 'CDR (CAR D-ASSEM::STACK-DEPTH))))) ((:PUSH-TAG) (D-ASSEM::EMIT-BYTE D-ASSEM::INST) (D-ASSEM::INCR D-ASSEM::DEPTH)) ((:JUMP) (* \; "JUMP opcode does NOT pop anything off the stack") (D-ASSEM::EMIT-BYTE D-ASSEM::INST)) ((:TJUMP :FJUMP :NTJUMP :NFJUMP) (* \; "Other jump opcodes DO pop (the NT & NF, only if the jump isn't taken). Since we're looking at stack depth right after this instruction, this means we can assume the jump didn't happen....") (D-ASSEM::EMIT-BYTE D-ASSEM::INST) (D-ASSEM::DECR D-ASSEM::DEPTH) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :JUMP)) ((:CALL) (DESTRUCTURING-BIND (D-ASSEM::FN-TO-CALL D-ASSEM::NUM-ARGS &KEY ((:NOT-INLINE D-ASSEM::NOT-INLINE?)) ((:SPREAD-LAST D-ASSEM::SPREAD-LAST?))(* \; "SPREAD-LAST? is the hook for APPLY and the interpreter hacks. Currently ignored. The idea is that you let the assembler put in the magic loop that spreads the last argument, and takes case of allocating the temps for that loop.") ) (CL:REST D-ASSEM::INST) (CL:TYPECASE D-ASSEM::FN-TO-CALL (CL:SYMBOL (* \; "External call") (LET ((D-ASSEM::DOPVAL (GET D-ASSEM::FN-TO-CALL 'DOPVAL))) (CL:BLOCK :CALL-PROCESSING (CL:UNLESS (OR D-ASSEM::NOT-INLINE? (NULL D-ASSEM::DOPVAL)) (CL:ASSERT (CL:CONSP D-ASSEM::DOPVAL) '(D-ASSEM::FN-TO-CALL D-ASSEM::DOPVAL) "DOPVAL for ~S is not a list: ~S" D-ASSEM::FN-TO-CALL D-ASSEM::DOPVAL) (FOR D-ASSEM::ITEM INSIDE (CL:IF (CL:ATOM (CAR D-ASSEM::DOPVAL )) (LIST D-ASSEM::DOPVAL) D-ASSEM::DOPVAL) DO (COND ((CL:ATOM D-ASSEM::ITEM) (* \; "The ITEM is OPT.COMPILERERROR. Compile the call closed.") (RETURN)) ((OR (NULL (CAR D-ASSEM::ITEM)) (= (CAR D-ASSEM::ITEM) D-ASSEM::NUM-ARGS)) (COND ((CL:CONSP (CDR D-ASSEM::ITEM)) (CL:MAPC 'D-ASSEM::EMIT-BYTE (CDR D-ASSEM::ITEM )) (CL:RETURN-FROM :CALL-PROCESSING)) (T (* \; "The ITEM is something like (0 . OPT.COMPILERERROR). Compile the call closed.") (RETURN))))))) (* |;;| "Either no DOPVAL or the DOPVAL failed. Compile as a closed call.") (COND ((<= D-ASSEM::NUM-ARGS 255) (D-ASSEM::EMIT-BYTE-LIST (CASE D-ASSEM::NUM-ARGS ((0) '(FN0)) ((1) '(FN1)) ((2) '(FN2)) ((3) '(FN3)) ((4) '(FN4)) (CL:OTHERWISE `(FNX ,D-ASSEM::NUM-ARGS)))) (D-ASSEM::EMIT-BYTE `(:FN ,D-ASSEM::FN-TO-CALL))) (T (* |;;| "Lots of arguments. Call using APPLYFN.") (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::PUSH-INTEGER D-ASSEM::NUM-ARGS)) (D-ASSEM::EMIT-BYTE-LIST `(ACONST (:FN ,D-ASSEM::FN-TO-CALL) APPLYFN))))))) (D-ASSEM::DVAR (* \; "Call a function that lives in a variable") (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::PUSH-INTEGER D-ASSEM::NUM-ARGS)) (COND ((EQ (D-ASSEM::DVAR-KIND D-ASSEM::FN-TO-CALL) :FUNCTION) (CL:ASSERT (NOT (NULL (D-ASSEM::DVAR-LEVEL D-ASSEM::FN-TO-CALL))) '(D-ASSEM::FN-TO-CALL) "BUG: The local function ~A should have a lexical level by now." (D-ASSEM::DVAR-NAME D-ASSEM::FN-TO-CALL)) (D-ASSEM::EMIT-BYTE-LIST `(GCONST (:LOCAL-FUNCTION ,D-ASSEM::FN-TO-CALL))) (COND ((AND NIL (CL:ZEROP (D-ASSEM::DVAR-LEVEL D-ASSEM::FN-TO-CALL))) (* \; "We used to do something different for an empty environment.") (* \; "No non-locals -- use applyfn.") (D-ASSEM::EMIT-BYTE 'APPLYFN)) (T (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::FETCH-HUNK (D-ASSEM::DVAR-LEVEL D-ASSEM::FN-TO-CALL)) ) (D-ASSEM::EMIT-BYTE 'ENVCALL)))) (T (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::REF-VAR D-ASSEM::FN-TO-CALL)) (D-ASSEM::EMIT-BYTE 'APPLYFN)))) (CONS (CL:ECASE (CL:FIRST D-ASSEM::FN-TO-CALL) ((:OPCODES) (D-ASSEM::EMIT-BYTE-LIST (CL:REST D-ASSEM::FN-TO-CALL))) ((:LAMBDA) (D-ASSEM::EMIT-BYTE-LIST (D-ASSEM::PUSH-INTEGER D-ASSEM::NUM-ARGS)) (LET ((D-ASSEM::DLAMBDA (CL:SECOND D-ASSEM::FN-TO-CALL)) (D-ASSEM::LAMBDA-LEVEL (CL:THIRD D-ASSEM::FN-TO-CALL))) (COND ((AND NIL (CL:ZEROP D-ASSEM::LAMBDA-LEVEL)) (* \; "We used to do something different for an empty environment.") (* |;;| "No closed-over variables: use APPLYFN.") (D-ASSEM::EMIT-BYTE-LIST `(GCONST (:LAMBDA 0 ,D-ASSEM::DLAMBDA) APPLYFN))) (T (* |;;| "This will need to be a closure. Find our best hunk for it and call using ENVCALL.") (D-ASSEM::EMIT-BYTE-LIST `(GCONST (:LAMBDA ,D-ASSEM::LAMBDA-LEVEL ,D-ASSEM::DLAMBDA) ,@(D-ASSEM::FETCH-HUNK D-ASSEM::LAMBDA-LEVEL) ENVCALL)))))))) (T (CL:ERROR "BUG: Weird argument to :CALL ~S" D-ASSEM::FN-TO-CALL))) (D-ASSEM::DECR D-ASSEM::DEPTH (CL:1- D-ASSEM::NUM-ARGS)) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :CALL))) ((:STKCALL) (D-ASSEM::EMIT-BYTE 'APPLYFN) (D-ASSEM::DECR D-ASSEM::DEPTH (CL:1+ (CL:SECOND D-ASSEM::INST))) (CL:ASSERT (OR (NOT D-ASSEM::DEPTH) (>= D-ASSEM::DEPTH 0)) NIL "Depth went negative in ~S." :STKCALL)) ((:RETURN) (D-ASSEM::EMIT-BYTE 'RETURN)) ((:CLOSE) (* \; "After digestion, this looks like this:") (* \; "(:CLOSE dvars hunk-slot . code).") (D-ASSEM::CREATE-HUNK (+ (CL:LIST-LENGTH (CL:SECOND D-ASSEM::INST)) (CL:IF (NULL D-ASSEM::*HUNK-MAP*) (* \; "If this hunk is not at level 0, we need an extra hunk slot in order to link it to the previous one.") 0 1)) (CL:THIRD D-ASSEM::INST) (CDAR D-ASSEM::*HUNK-MAP*) T) (LET* ((D-ASSEM::*LEVEL* (CL:1+ D-ASSEM::*LEVEL*)) (D-ASSEM::*HUNK-MAP* (CONS (CONS D-ASSEM::*LEVEL* (CL:THIRD D-ASSEM::INST)) D-ASSEM::*HUNK-MAP*))) (CL:SETQ D-ASSEM::DEPTH (D-ASSEM::ASSEMBLE-CODE (CDDDR D-ASSEM::INST) D-ASSEM::DEPTH D-ASSEM::BINDING-DEPTH)) (CL:ASSERT (>= D-ASSEM::DEPTH 0) (OR (NOT D-ASSEM::DEPTH)) NIL "Depth went negative in ~S." :CLOSE)))))) D-ASSEM::DEPTH) (PUTPROPS AR-10922-PATCH FILETYPE CL:COMPILE-FILE) (PUTPROPS AR-10922-PATCH COPYRIGHT ("ENVOS Corporation" 1988)) (DECLARE\: DONTCOPY (FILEMAP (NIL))) STOP