(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "26-Jan-98 13:53:42" ("compiled on " {DSK}disk2>jdstools>lc3>lispcore3.0>sources>UNWINDMACROS.;1) "30-Mar-95 20:33:04" "COMPILE-FILEd" in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48") (FILECREATED "17-May-90 16:11:33" {DSK}local>lde>lispcore>sources>UNWINDMACROS.;2 12143 changes to%: (VARS UNWINDMACROSCOMS) previous date%: "27-May-87 16:49:53" {DSK}local>lde>lispcore>sources>UNWINDMACROS.;1) (RPAQQ UNWINDMACROSCOMS ((* ;; "macros for use with the new unwinder ") (FUNCTIONS NLSETQ ERSETQ) ( MACROS RESETLST RESETFORM RESETVARS XNLSETQ RESETVAR RESETSAVE UNDONLSETQ) (PROP DMACRO CL:CATCH CL:THROW CL:UNWIND-PROTECT) (MACROS .CATCH. .UNWIND.PROTECT. .RESETLST.) (FNS COMP.CATCH COMP.UNWIND-PROTECT) (ADDVARS (SYSSPECVARS SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*)) (PROP FILETYPE UNWINDMACROS))) expand-NLSETQ :D8 (L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) p@gogggooggggggHhhohoohNIL (69 PROGN 64 LIST 59 SI::NLSETQ-VALUE 54 CL:SETQ 49 *PROCEED-CASES* 44 CL:CATCH 29 LET 24 EQ 19 CL:IF 9 LET) ( 103 (SI::NLSETQ-VALUE NIL) 96 (:NORMAL) 83 (:NORMAL) 39 (DECLARE (SPECVARS SI::*NLSETQFLAG*)) 34 ((*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*)) (SI::*NLSETQFLAG* T) (*CONDITION-HANDLER-BINDINGS* (CONS (QUOTE (CL:ERROR . SI::NLSETQHANDLER)) *CONDITION-HANDLER-BINDINGS*))) 14 (SI::NLSETQ-VALUE)) (SETF-MACRO-FUNCTION (QUOTE NLSETQ) (QUOTE expand-NLSETQ)) expand-ERSETQ :D8 (L (1 SI::$$MACRO-ENVIRONMENT 0 SI::$$MACRO-FORM)) p@gogggooggggggHhhohoohNIL (69 PROGN 64 LIST 59 SI::NLSETQ-VALUE 54 CL:SETQ 49 *PROCEED-CASES* 44 CL:CATCH 29 LET 24 EQ 19 CL:IF 9 LET) ( 103 (SI::NLSETQ-VALUE NIL) 96 (:NORMAL) 83 (:NORMAL) 39 (DECLARE (SPECVARS SI::*NLSETQFLAG*)) 34 ((*PROCEED-CASES* (CONS SI::NLSETQ-PROCEED-CASE *PROCEED-CASES*)) (SI::*NLSETQFLAG* NIL)) 14 (SI::NLSETQ-VALUE)) (SETF-MACRO-FUNCTION (QUOTE ERSETQ) (QUOTE expand-ERSETQ)) (PUTPROPS RESETLST MACRO ((X . Y) (.RESETLST. (PROGN X . Y) NIL ((LISPXHIST LISPXHIST) (RESETSTATE NIL ))))) (PUTPROPS RESETFORM MACRO (TAIL (BQUOTE (.RESETLST. (PROGN (\,@ (CDR TAIL))) (LIST (LIST (LIST (QUOTE (\, (CAAR TAIL))) (\, (CAR TAIL))))))))) (PUTPROPS RESETVARS MACRO (TAIL (LET ((VARS (MAPCAR (CAR TAIL) (FUNCTION (LAMBDA (Z) (SETQ Z (MKLIST Z )) (COND ((AND EMFLAG (NOT (COMP.GLOBALVARP (CAR Z)))) (COMPERRM (LIST (CAR Z) "- not GLOBALVAR in RESETVARS")))) Z))))) (BQUOTE (.RESETLST. (PROG NIL (* ; "Set the variables to new values, execute forms, all inside a prog") (\,. (MAPCAR VARS (FUNCTION ( LAMBDA (V) (CONS (QUOTE SETQ) V))))) (\,@ (CDR TAIL))) (PROGN (* ; "Initialize *RESETFORMS* to list of vars and old values") (LIST (\,@ (MAPCAR VARS (FUNCTION (LAMBDA (V ) (BQUOTE (CONS (QUOTE (\, (CAR V))) (\, (CAR V))))))))))))))) (PUTPROPS XNLSETQ MACRO ((X) (NLSETQ X))) (PUTPROPS RESETVAR MACRO ((VAR VAL FORM) (.RESETLST. (PROGN (SETTOPVAL (QUOTE VAR) VAL) FORM) (LIST ( CONS (QUOTE VAR) (GETTOPVAL (QUOTE VAR))))))) (PUTPROPS RESETSAVE MACRO (X (BQUOTE (SETQ SI::*RESETFORMS* (CONS (\, (COND ((AND (ATOM (CAR X)) (CAR X)) (SUBPAIR (QUOTE (VAR VAL)) X (QUOTE (PROG1 (CONS (QUOTE VAR) (GETTOPVAL (QUOTE VAR))) (SETTOPVAL ( QUOTE VAR) VAL))))) ((CDR X) (BQUOTE (LIST (\, (CADR X)) (\, (CAR X))))) (T (BQUOTE (LIST (LIST (QUOTE (\, (COND ((EQ (CAAR X) (QUOTE SETQ)) (CAR (CADDAR X))) (T (CAAR X))))) (\, (CAR X)))))))) SI::*RESETFORMS*))))) (PUTPROPS UNDONLSETQ MACRO ((UNDOFORM UNDOFN) (PROG ((LISPXHIST LISPXHIST) UNDOSIDE0 UNDOSIDE UNDOTEM) (DECLARE (SPECVARS LISPXHIST)) (COND ((LISTP (SETQ UNDOSIDE (LISTGET1 LISPXHIST (QUOTE SIDE)))) (SETQ UNDOSIDE0 (CDR UNDOSIDE))) (T (SETQ UNDOSIDE0 UNDOSIDE) (SETQ UNDOSIDE (LIST 0)) (COND (LISPXHIST ( LISTPUT1 LISPXHIST (QUOTE SIDE) UNDOSIDE)) (T (SETQ LISPXHIST (LIST (QUOTE SIDE) UNDOSIDE)))))) ( RESETVARS (%#UNDOSAVES) (SETQ UNDOTEM (XNLSETQ UNDOFORM NIL UNDOFN))) (COND ((EQ UNDOSIDE0 (QUOTE NOSAVE)) (LISTPUT1 LISPXHIST (QUOTE SIDE) (QUOTE NOSAVE))) (T (UNDOSAVE))) (COND (UNDOTEM (RETURN UNDOTEM))) (UNDONLSETQ1 (CDR UNDOSIDE) (LISTP UNDOSIDE0)) (RETURN)))) (PUTPROPS CL:CATCH DMACRO ((TAG . BODY) (.CATCH. TAG (PROGN . BODY)))) (PUTPROPS CL:THROW DMACRO (DEFMACRO (TAG VALUE) (COND ((NLISTP VALUE) (* ; "simple one-valued case") ( BQUOTE (SI::INTERNAL-THROW (\, TAG) (\, VALUE)))) ((EQ (CAR VALUE) (QUOTE CL:VALUES)) (* ; "simple multi-valued case") (BQUOTE (SI::INTERNAL-THROW (\, TAG) (\,@ (CDR VALUE))))) (T (* ; "general multi-valued case") (BQUOTE (SI::INTERNAL-THROW-VALUES (\, TAG) (CL:MULTIPLE-VALUE-LIST (\, VALUE)))))))) (PUTPROPS CL:UNWIND-PROTECT DMACRO (DEFMACRO (FORM &REST CLEANUP-FORMS) (BQUOTE (CL:MULTIPLE-VALUE-PROG1 (.UNWIND.PROTECT. (FUNCTION (\, (COND ((AND (NULL (CDR CLEANUP-FORMS)) (LISTP (CAR CLEANUP-FORMS)) ( NULL (CDAR CLEANUP-FORMS))) (* ; "Optimize case of no-argument single cleanup fn") (CAAR CLEANUP-FORMS )) (T (BQUOTE (LAMBDA NIL (\,@ CLEANUP-FORMS))))))) (\, FORM)) (\,@ CLEANUP-FORMS))))) (PUTPROPS .CATCH. DMACRO (APPLY COMP.CATCH)) (PUTPROPS .UNWIND.PROTECT. DMACRO (APPLY COMP.UNWIND-PROTECT)) (PUTPROPS .RESETLST. DMACRO (DEFMACRO (FORM &OPTIONAL INIT OTHERBINDINGS) (BQUOTE (LET (( SI::*RESETFORMS* (\, INIT)) (\,@ OTHERBINDINGS)) (DECLARE (SPECVARS SI::*RESETFORMS* (\,@ (MAPCAR OTHERBINDINGS (QUOTE CAR))))) (CL:UNWIND-PROTECT (\, FORM) (SI::RESETUNWIND)))))) COMP.CATCH :D8 (I 1 FORM I 0 ARG) 3gggooAhh @hj(48 COMP.CALL 39 COMP.LAM1) (14 LET 9 NOBIND 4 LAMBDA) ( 24 (DECLARE (CL:SPECIAL SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*)) 19 ((SI::*DUMMY-FOR-CATCH* T) (SI::*CATCH-RETURN-FROM* ((OPCODES (IVAR 0)))))) COMP.UNWIND-PROTECT :D8 (I 1 FORM I 0 CLEANUPFN) +goooAh @hj(40 COMP.CALL 31 COMP.LAM1) (4 LAMBDA) ( 19 (\CALLME (QUOTE SI::*UNWIND-PROTECT*)) 14 (DECLARE (SPECVARS SI::*CLEANUP-FORMS*)) 9 (SI::*CLEANUP-FORMS*)) (ADDTOVAR SYSSPECVARS SI::*DUMMY-FOR-CATCH* SI::*CATCH-RETURN-FROM*) (PUTPROPS UNWINDMACROS FILETYPE COMPILE-FILE) (PUTPROPS UNWINDMACROS COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990)) NIL