(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "15-Feb-88 15:56:33" {ERINYES}<LISPLIBRARY>LYRIC>MVALUESPATCH.;1 4809
changes to%: (VARS MVALUESPATCHCOMS))
(* "
Copyright (c) 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT MVALUESPATCHCOMS)
(RPAQQ MVALUESPATCHCOMS ((* ;;; "Lyric patch to Runtime support for multiple value passing--this allows multiple values to be passed thru unbinds, something needed by Interlisp compilation of ignore-errors and friends.") (FNS CL:VALUES CL:VALUES-LIST \SIMULATE.UNBIND) (DECLARE%: DONTCOPY (MACROS \VALUES) (LOCALVARS . T)) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML) (LAMA CL:VALUES))))
)
(* ;;;
"Lyric patch to Runtime support for multiple value passing--this allows multiple values to be passed thru unbinds, something needed by Interlisp compilation of ignore-errors and friends."
)
(DEFINEQ
(CL:VALUES
(LAMBDA ARGS (* lmm " 1-May-86 23:51") (\VALUES (for I from 1 to ARGS collect (ARG ARGS I)) (AND (IGEQ ARGS 1) (ARG ARGS 1))))
)
(CL:VALUES-LIST
(LAMBDA (CL:VALUES) (* lmm " 7-Feb-86 14:36") (\VALUES CL:VALUES (CAR CL:VALUES))))
(\SIMULATE.UNBIND
(LAMBDA (FRAME N RETURNER) (* ; "Edited 25-Nov-87 12:54 by bvm:") (* ;; "Simulate the action of N applications of UNBIND occurring in specified FRAME. RETURNER is the frame that will return to FRAME, and hence must be made slow (NIL if my caller). Must be called uninterruptably.") (LET* ((NEXT (fetch (FX NEXTBLOCK) of FRAME)) (SP NEXT) (PVAR0BASE (STACKADDBASE (fetch (FX FIRSTPVAR) of FRAME)))) (TO N DO (do (* ; "Pop stack until a bind mark is encountered") (SETQ SP (- SP WORDSPERCELL)) REPEATUNTIL (fetch BINDMARKP of (STACKADDBASE SP)) FINALLY (* ; "Unbind stuff. Bind mark says how many pvars were bound, and gives the offset of the last of them") (LET ((LASTPVAR (fetch BINDLASTPVAR of (STACKADDBASE SP)))) (to (fetch BINDNVALUES of (STACKADDBASE SP)) do (\PUTBASE PVAR0BASE LASTPVAR 65535) (SETQ LASTPVAR (- LASTPVAR WORDSPERCELL)))))) (replace (FX NEXTBLOCK) of FRAME with SP) (\MAKEFREEBLOCK SP (- NEXT SP)) (* ;; "Now explicitly slow return to FRAME, since we have violated the fast return assumptions by blowing away stack between here and there") (replace (FX FASTP) of (OR RETURNER (\MYALINK)) with NIL)))
)
)
(DECLARE%: DONTCOPY
(DECLARE%: EVAL@COMPILE
(PUTPROPS \VALUES MACRO ((MANY ONE) (PROG ((CALLER (\MYALINK)) PREVFRAME) (* ;; "This macro is used by VALUES and VALUES-LIST to possibly return multiple values. It works by examining the caller to see if the next instruction is MVLIST (currently in the form of a FN1 \MVLIST), which is present in all multiple-value receivers. If so, it bumps the pc past there and returns the MANY expression, whose value is a list of all the values. If it encounters RETURN instead, the call was tail-recursive, so procedure repeats with caller's caller, etc. Otherwise, multiple values are not expected, and the macro returns just ONE value (the first) to the caller.") NEWFRAME (RETURN (PROG ((PC (fetch (FX PC) of CALLER)) (CODE (fetch (FX FNHEADER) of CALLER)) (NUNBINDS 0) BYTE) NEWPC (SELECTC (SETQ BYTE (\GETBASEBYTE CODE PC)) ((LIST (OP# RETURN) (OP# \RETURN)) (* ; "Call is tail-recursive, so iterate. \RETURN is for LLBREAKing.") (SETQ PREVFRAME CALLER) (SETQ CALLER (fetch (FX CLINK) of CALLER)) (GO NEWFRAME)) ((OP# FN1) (* ; "Could be MVLIST") (SELECTQ (\INDEXATOMDEF (create WORD HIBYTE ← (\GETBASEBYTE CODE (+ PC 1)) LOBYTE ← (\GETBASEBYTE CODE (+ PC 2)))) (\MVLIST (* ; "Bump PC past the call, and return the values list") (UNINTERRUPTABLY (if (NEQ NUNBINDS 0) then (* ; "Sigh. We have to simulate the unbinding, since we need to get past the MVLIST.") (\SIMULATE.UNBIND CALLER NUNBINDS PREVFRAME)) (replace (FX PC) of CALLER with (+ PC 3))) (RETURN MANY)) NIL)) ((OP# UNBIND) (* ; "UNBIND appears. This preserves the top of stack, so it should also preserve multiple values.") (add PC 1) (add NUNBINDS 1) (GO NEWPC)) ((OP# JUMPX) (* ; "Follow the jump (yecch)") (add PC (if (>= (SETQ BYTE (\GETBASEBYTE CODE (+ PC 1))) 128) then (- BYTE 256) else BYTE)) (GO NEWPC)) ((OP# JUMPXX) (add PC (SIGNED (create WORD HIBYTE ← (\GETBASEBYTE CODE (+ PC 1)) LOBYTE ← (\GETBASEBYTE CODE (+ PC 2))) BITSPERWORD)) (GO NEWPC)) (LET ((JUMPBASE (CONSTANT (CAAR (\FINDOP (QUOTE JUMP)))))) (if (<= JUMPBASE BYTE (CONSTANT (CADAR (\FINDOP (QUOTE JUMP))))) then (add PC (+ (- BYTE JUMPBASE) 2)) (GO NEWPC)))) (RETURN ONE))))))
)
(DECLARE%: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
)
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA CL:VALUES)
)
(PUTPROPS MVALUESPATCH COPYRIGHT ("Xerox Corporation" 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (952 2362 (CL:VALUES 962 . 1105) (CL:VALUES-LIST 1107 . 1210) (\SIMULATE.UNBIND 1212 .
2360)))))
STOP