initial checkin for sources
This commit is contained in:
Larry Masinter
222
sources/RENAMEMACROS
Normal file
222
sources/RENAMEMACROS
Normal file
@@ -0,0 +1,222 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "27-Apr-94 15:43:27" {DSK}<king>export>lispcore>sources>RENAMEMACROS.;2)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1985, 1986, 1990, 1994 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT RENAMEMACROSCOMS)
|
||||
|
||||
(RPAQQ RENAMEMACROSCOMS
|
||||
(
|
||||
(* ;; "MACROS FOR CODE THAT NEEDS TO CHANGE WHEN YOU RUN IT RENAMED.")
|
||||
|
||||
[COMS (* ;
|
||||
"Things that change when we're renaming for RDSYS/TELERAID")
|
||||
(ADDVARS (RD.SUBFNS (UNLESSRDSYS . 2ND)
|
||||
(\GETBITS . RNGETBITS)
|
||||
(\PUTBITS . RNPUTBITS]
|
||||
[COMS (* ;
|
||||
"Things that change when we're making I-NEW, for building a new loadup.")
|
||||
(ADDVARS (MKI.SUBFNS (UNLESSINEW . 2ND)
|
||||
(\GETBITS . RNGETBITS)
|
||||
(\PUTBITS . RNPUTBITS]
|
||||
|
||||
(* ;; "Force these macros to be expanded while renaming:")
|
||||
|
||||
(ADDVARS (EXPANDMACROFNS 1ST 2ND UNLESSRDSYS UNLESSINEW RNGETBITS RNPUTBITS \TESTBITS)
|
||||
(EXPANDMACROFNS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE
|
||||
PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC))
|
||||
|
||||
(* ;; "MACROS TO CONTROL EFFECTS:")
|
||||
|
||||
|
||||
(* ;; "(UNLESSRDSYS normal rdsys) expands to one form or the other, depending on whether you're making a RDSYS.")
|
||||
|
||||
|
||||
(* ;; "(UNLESSINEW normal inew) expandes to one form or the other, depending on whether you're makeing an I-NEW.")
|
||||
|
||||
|
||||
(* ;; "(1ST ...) expands to its first argument")
|
||||
|
||||
|
||||
(* ;; "(2ND ...) expands to its second argument. These are used in epxanding UNLESS...")
|
||||
|
||||
(EXPORT (MACROS UNLESSRDSYS UNLESSINEW 1ST 2ND LOCAL ALLOCAL)
|
||||
(MACROS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE
|
||||
PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC))
|
||||
(MACROS RNPUTBITS RNGETBITS)))
|
||||
|
||||
|
||||
|
||||
(* ;; "MACROS FOR CODE THAT NEEDS TO CHANGE WHEN YOU RUN IT RENAMED.")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ; "Things that change when we're renaming for RDSYS/TELERAID")
|
||||
|
||||
|
||||
(ADDTOVAR RD.SUBFNS (UNLESSRDSYS . 2ND)
|
||||
(\GETBITS . RNGETBITS)
|
||||
(\PUTBITS . RNPUTBITS))
|
||||
|
||||
|
||||
|
||||
(* ; "Things that change when we're making I-NEW, for building a new loadup.")
|
||||
|
||||
|
||||
(ADDTOVAR MKI.SUBFNS (UNLESSINEW . 2ND)
|
||||
(\GETBITS . RNGETBITS)
|
||||
(\PUTBITS . RNPUTBITS))
|
||||
|
||||
|
||||
|
||||
(* ;; "Force these macros to be expanded while renaming:")
|
||||
|
||||
|
||||
(ADDTOVAR EXPANDMACROFNS 1ST 2ND UNLESSRDSYS UNLESSINEW RNGETBITS RNPUTBITS \TESTBITS)
|
||||
|
||||
(ADDTOVAR EXPANDMACROFNS ADDBASE GETBASE GETBASEBYTE GETBASEPTR HILOC LOLOC PUTBASE PUTBASEBYTE
|
||||
PUTBASEPTR REPLACEPTRFIELD VAG2 PAGEBASE PAGELOC)
|
||||
|
||||
|
||||
|
||||
(* ;; "MACROS TO CONTROL EFFECTS:")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"(UNLESSRDSYS normal rdsys) expands to one form or the other, depending on whether you're making a RDSYS."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"(UNLESSINEW normal inew) expandes to one form or the other, depending on whether you're makeing an I-NEW."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;; "(1ST ...) expands to its first argument")
|
||||
|
||||
|
||||
|
||||
|
||||
(* ;; "(2ND ...) expands to its second argument. These are used in epxanding UNLESS...")
|
||||
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS UNLESSRDSYS MACRO ((NORMAL RDSYS)
|
||||
NORMAL))
|
||||
|
||||
(PUTPROPS UNLESSINEW MACRO ((NORMAL I-NEW)
|
||||
NORMAL))
|
||||
|
||||
(PUTPROPS 1ST MACRO ((A . B)
|
||||
A))
|
||||
|
||||
(PUTPROPS 2ND MACRO ((A B . C)
|
||||
B))
|
||||
|
||||
(PUTPROPS LOCAL MACRO ((X)
|
||||
X))
|
||||
|
||||
(PUTPROPS ALLOCAL MACRO ((X)
|
||||
X))
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS ADDBASE DMACRO (= . \ADDBASE))
|
||||
|
||||
(PUTPROPS GETBASE DMACRO (= . \GETBASE))
|
||||
|
||||
(PUTPROPS GETBASEBYTE DMACRO (= . \GETBASEBYTE))
|
||||
|
||||
(PUTPROPS GETBASEPTR DMACRO (= . \GETBASEPTR))
|
||||
|
||||
(PUTPROPS HILOC DMACRO (= . \HILOC))
|
||||
|
||||
(PUTPROPS LOLOC DMACRO (= . \LOLOC))
|
||||
|
||||
(PUTPROPS PUTBASE DMACRO (= . \PUTBASE))
|
||||
|
||||
(PUTPROPS PUTBASEBYTE DMACRO (= . \PUTBASEBYTE))
|
||||
|
||||
(PUTPROPS PUTBASEPTR DMACRO (= . \PUTBASEPTR))
|
||||
|
||||
(PUTPROPS REPLACEPTRFIELD DMACRO (= . \RPLPTR))
|
||||
|
||||
(PUTPROPS VAG2 DMACRO (= . \VAG2))
|
||||
|
||||
(PUTPROPS PAGEBASE MACRO ((PTR)
|
||||
(fetch (POINTER PAGEBASE) of PTR)))
|
||||
|
||||
[PUTPROPS PAGELOC MACRO (OPENLAMBDA (PTR)
|
||||
(IPLUS (LLSH (\HILOC PTR)
|
||||
8)
|
||||
(LRSH (\LOLOC PTR)
|
||||
8]
|
||||
)
|
||||
|
||||
(* "END EXPORTED DEFINITIONS")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
[PUTPROPS RNPUTBITS MACRO (X ([LAMBDA (DATUM OFFSET FD NEWVALUE)
|
||||
(PROG ((MASK (BitFieldMask FD))
|
||||
(SHIFT (BitFieldShift FD))
|
||||
(FIRST (BitFieldFirst FD)))
|
||||
(OR (EQ FIRST 0)
|
||||
(SETQ NEWVALUE (LIST 'LOGAND NEWVALUE MASK)))
|
||||
(OR (EQ SHIFT 0)
|
||||
(SETQ NEWVALUE (LIST 'LLSH NEWVALUE SHIFT)))
|
||||
[COND
|
||||
((AND (EQ FIRST 0)
|
||||
(EQ SHIFT 0))
|
||||
(SETQ NEWVALUE (LIST '\PUTBASE DATUM OFFSET NEWVALUE)))
|
||||
(T (SETQ NEWVALUE (LIST 'LOGOR
|
||||
(LIST 'LOGAND (LIST '\GETBASE
|
||||
'$$PUTBITS
|
||||
OFFSET)
|
||||
(LOGXOR 65535 (LLSH MASK SHIFT
|
||||
)))
|
||||
NEWVALUE))
|
||||
(SETQ NEWVALUE (LIST (LIST 'OPENLAMBDA '($$PUTBITS)
|
||||
(LIST '\PUTBASE '$$PUTBITS
|
||||
OFFSET NEWVALUE))
|
||||
DATUM]
|
||||
[COND
|
||||
((NOT EFF)
|
||||
(OR (EQ SHIFT 0)
|
||||
(SETQ NEWVALUE (LIST 'LRSH NEWVALUE SHIFT)))
|
||||
(OR (EQ FIRST 0)
|
||||
(SETQ NEWVALUE (LIST 'LOGAND NEWVALUE MASK]
|
||||
(RETURN NEWVALUE]
|
||||
(CAR X)
|
||||
(CADR X)
|
||||
(CADDR X)
|
||||
(CADDDR X]
|
||||
|
||||
[PUTPROPS RNGETBITS MACRO (X ([LAMBDA (FORM OFFSET FD)
|
||||
(COND
|
||||
((NOT (FIXP FD))
|
||||
'IGNOREMACRO)
|
||||
(T (SETQ FORM (LIST '\GETBASE FORM OFFSET))
|
||||
[OR (EQ (BitFieldShift FD)
|
||||
0)
|
||||
(SETQ FORM (LIST 'LRSH FORM (BitFieldShift FD]
|
||||
[OR (EQ (BitFieldFirst FD)
|
||||
0)
|
||||
(SETQ FORM (LIST 'LOGAND FORM (BitFieldMask FD]
|
||||
FORM]
|
||||
(CAR X)
|
||||
(CADR X)
|
||||
(CADDR X]
|
||||
)
|
||||
(PUTPROPS RENAMEMACROS COPYRIGHT ("Venue & Xerox Corporation" 1982 1985 1986 1990 1994))
|
||||
STOP
|
||||
Reference in New Issue
Block a user