mirror of
https://github.com/PDP-10/its.git
synced 2026-02-08 01:11:18 +00:00
454 lines
17 KiB
Plaintext
454 lines
17 KiB
Plaintext
|
||
;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;; DEFINE > ;;;;
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;;;
|
||
;;THIS FILE IS INTENDED FOR:
|
||
;;; DEFINING LLOGO PRIMITIVES
|
||
;;; READING IN DECLARATIONS AND MACROS FOR COMPILING PIECES OF LLOGO.
|
||
;;;
|
||
;; IT CONTAINS DEFINITIONS OF READMACROS, COMPILER-EXPANDED MACROS, DEFINITION OF
|
||
;;DEFINE FUNCTION. NOTE THAT THIS FILE ITSELF MUST BE READ INTO COMPILER TO COMPILE
|
||
;;IT. NOTHING IN THIS FILE WILL BE PRESENT IN COMPILED LLOGO, EXCEPT THAT DEFINE
|
||
;;FUNCTION WILL BE AUTOLOADED.
|
||
|
||
(DECLARE (SPECIAL SYNSTAX TTYNOTES DEFINE-MACRO-INDEX)
|
||
(MACROS T)
|
||
(GENPREFIX DEFINE-)
|
||
(COND ((STATUS FEATURE DEFINE))
|
||
((AND (OR (STATUS FEATURE ITS) (STATUS FEATURE DEC10))
|
||
(ERRSET (FASLOAD DEFINE FASL DSK LLOGO))))
|
||
((AND (STATUS FEATURE MULTICS)
|
||
(ERRSET (LOAD "DEFINE.LISP"))))
|
||
((IOG NIL (PRINT '(DEFINE MUST BE READ INTO COMPILER))))))
|
||
|
||
(DECLARE (READ))
|
||
|
||
(AND (STATUS FEATURE ITS)
|
||
(OR (STATUS FEATURE NCOMPLR) (STATUS FEATURE COMPLR))
|
||
;;READING IN TO COMPILER INTERPRETIVELY TO COMPILE ITSELF, MUST CHANGE OBARRAY
|
||
;;AND READTABLE SO DEFINITIONS OF READMACROS, ETC. WILL WIND UP ON CORRECT
|
||
;;ONES.
|
||
(SETQ OBARRAY COBARRAY READTABLE CREADTABLE))
|
||
|
||
(SSTATUS FEATURE DEFINE)
|
||
|
||
(*RSET T)
|
||
|
||
(SETQ CAR T CDR T NO-VALUE '?)
|
||
|
||
;;TO SET CONDITIONAL READ IN SWITCHES WHILE COMPILING, TYPE CONTROL-G AT COMPLR,
|
||
;;(SETQ <SWITCH> <VALUE>) THEN (MAKLAP) TO RETURN TO COMPILER COMMAND LEVEL. IN
|
||
;;COMPILERS >= VERSION 489, A "&" IS REQUIRED BEFORE THE SETQ TO SET THE VARIABLES
|
||
;;ON THE RIGHT OBARRAY.
|
||
|
||
(COND ((BOUNDP 'THIS-SYSTEM)
|
||
(SETQ ITS (EQ THIS-SYSTEM 'ITS) DEC10 (EQ THIS-SYSTEM 'DEC10)))
|
||
((SETQ ITS (STATUS FEATURE ITS) DEC10 (STATUS FEATURE DEC10))))
|
||
|
||
;;THIS-SYSTEM IS A VARIABLE DENOTING THE CURRENT IMPLEMENTATION. IF NOT PREVIOUSLY
|
||
;;SET, DEDUCED FROM (STATUS FEATURES). ATOM "MULTICS" HAS CAPITAL "M", SO REPLACE
|
||
;;WITH SMALL.
|
||
|
||
(SETQ MULTICS (AND (NOT ITS) (NOT DEC10)))
|
||
|
||
;;CLOGO VS. 11LOGO COMPATIBILITY SWITCH. [11LOGO DEFAULT]
|
||
|
||
(COND ((BOUNDP 'CLOGO) (SETQ /11LOGO (NOT CLOGO)))
|
||
((BOUNDP '/11LOGO) (SETQ CLOGO (NOT /11LOGO)))
|
||
((SETQ /11LOGO T CLOGO NIL)))
|
||
|
||
(OR (BOUNDP ':CAREFUL) (SETQ :CAREFUL T))
|
||
|
||
(OR (BOUNDP 'BIBOP) (SETQ BIBOP ITS))
|
||
|
||
(SETQ COMPILING (OR (STATUS FEATURE COMPLR)
|
||
;;VARIOUS INCARNATIONS OF THE LISP COMPILER ARE NAMED
|
||
;;DIFFERENTLY.
|
||
(STATUS FEATURE NCOMPLR)
|
||
(STATUS FEATURE COMPILER)))
|
||
|
||
;;READ-TIME SWITCH FOR IMPLEMENTATION-DEPENDENT CODE. OPEN BRACKET IS DEFINED TO BE
|
||
;;A READMACRO [ON LISP READTABLE ONLY] WHICH PICKS UP THE NEXT OBJECT, AND EVALUATES
|
||
;;IT. IF IT EVALUATES TO NON-NIL, BRACKETS DISAPPEAR. IF IN THE WRONG SYSTEM,
|
||
;;EVERYTHING IS DISCARDED UP TO THE NEXT CLOSE BRACKET. EXAMPLE:
|
||
;;; [MULTICS <CODE GOOD ONLY IN MULTICS>]
|
||
;;; [(OR ITS DEC10) <CODE GOOD IN EITHER ITS OR DEC10, NOT MULTICS>]
|
||
|
||
(SETQ SYNSTAX NIL GENSYM (GENSYM))
|
||
|
||
;;TO ALLOW NESTING OF SQUARE-BRACKET MACROS, A STACK OF SYNTAX PROPERTIES FOR
|
||
;;CLOSE-BRACKET IS KEPT, CHANGED WHEN AN OPEN BRACKET IS ENCOUNTERED, RESTORED WHEN
|
||
;;A CLOSE-BRACKET IS MET.
|
||
|
||
(DEFUN OPEN-BRACKET-MACRO NIL
|
||
(SETQ SYNSTAX (CONS (STATUS MACRO 93.) SYNSTAX))
|
||
(COND ((EVAL (READ))
|
||
(SETSYNTAX 93. 'SPLICING 'RESTORE-CLOSE-BRACKET-SYNTAX))
|
||
((SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO)
|
||
;;IN THE WRONG SYSTEM, GOBBLE AND DISCARD EVERYTHING TILL THE NEXT
|
||
;;CLOSE BRACKET. SYNTAX OF CLOSE-BRACKET MUST BE CHANGED TO MAKE IT
|
||
;;REAPPEAR.
|
||
(DO ((STUFF (READ) (READ)))
|
||
((EQ STUFF GENSYM) (RESTORE-CLOSE-BRACKET-SYNTAX)))))
|
||
NIL)
|
||
|
||
(SETSYNTAX 91. 'SPLICING 'OPEN-BRACKET-MACRO)
|
||
|
||
(DEFUN RESTORE-CLOSE-BRACKET-SYNTAX NIL
|
||
(SETSYNTAX 93. (OR (CADAR SYNSTAX) 'MACRO) (CAAR SYNSTAX))
|
||
(SETQ SYNSTAX (CDR SYNSTAX))
|
||
NIL)
|
||
|
||
(DEFUN CLOSE-BRACKET-MACRO NIL GENSYM)
|
||
|
||
(SETSYNTAX 93. 'MACRO 'CLOSE-BRACKET-MACRO)
|
||
|
||
;;DOUBLE-QUOTE IS DEFINED ON THE LISP READTABLE TO BE A PL/1-TYPE STRING-QUOTING
|
||
;;MACRO. IN THE MULTICS IMPLEMENTATION, STRINGS ARE IMPLEMENTED DIRECTLY.
|
||
|
||
[(OR ITS DEC10) (DEFUN DOUBLE-QUOTE-MACRO NIL
|
||
(DO ((CHARLIST) (CHARNUM (TYI) (TYI)))
|
||
((AND (= CHARNUM 34.) (NOT (= (TYIPEEK) 34.)))
|
||
(MAKNAM (NREVERSE CHARLIST)))
|
||
(AND (= CHARNUM 34.) (TYI))
|
||
(SETQ CHARLIST (CONS CHARNUM CHARLIST))))
|
||
(SETSYNTAX 34. 'MACRO 'DOUBLE-QUOTE-MACRO)]
|
||
|
||
;;NOTE THAT THE DOUBLE-QUOTE MACRO DOES NOT INTERN THE ATOM CREATED. END OF
|
||
;;READMACRO CHARACTER DEFINITIONS.
|
||
;;*PAGE
|
||
|
||
;; COMPILER DECLARATIONS AND MACROS.
|
||
|
||
(AND COMPILING
|
||
;;OPEN CODE MAP'S, FLUSH KLUDGY EXPR-HASH FEATURE, NO FUNCTIONAL VARIABLES.
|
||
(SETQ MAPEX T EXPR-HASH NIL NFUNVARS T)
|
||
(*FEXPR DEFINE DUMP ERASE IF IFFALSE IFTRUE LISPBREAK LOGOBREAK LOGO-EDIT
|
||
LOAD-IF-WANTED LOGIN PRINTOUTFILE PRINTOUTINDEX PRINTOUTTITLE PRINTOUT
|
||
READFILE REMGRIND REMTRACE SAVE TO TRACE UNTRACE USE WRITE)
|
||
(*LEXPR DPRINTL EXIT ERRBREAK LOCATE-ERROR LOGOREAD LOGO-PRINT LOGO-RANDOM
|
||
ATOMIZE PARSELINE ROUNDOFF SENTENCE TYPE WORD WRITELIST)
|
||
(*EXPR ABB1 ADDLINE ABBREVIATIONP ASK ALLOCATOR BIND-ACTIVATE-LISP
|
||
BIND-ACTIVATE-LOGO CONTROL-N CONTROL-P CONTROL-R CONTROL-S DATE DAYTIME
|
||
DEFAULT-FUNCTION DELEET DPRINC DPRINT DTERPRI EDITINIT1 EDIT-LINE
|
||
ERASELINE ERRORFRAME EVALS EXPUNGE ERASEPRIM FILESPEC FUNCTION-PROP
|
||
GETLINE HOW-TO-PARSE-INPUTS HOMCHECK INIT LINE LISP LOGO LOGOPRINC MAKE
|
||
MAKLOGONAM NUMBER? OBTERN OUTPUT PARSE PASS2 PASS2-ERROR PRINTOUTLINES
|
||
PRINTOUTNAMES PRINTOUTPROCEDURES PRINTOUTTITLES PRIMITIVEP PROCEDUREP
|
||
REPAIR-LINE REQUEST REMSNAP REREAD-ERROR SCREENSIZE SET- SYNONYMIZE
|
||
SYMBOLP TOP-LEVEL TRACE? TRACED? UNITE UNPARSE-FORM
|
||
UNPARSE-FUNCTION-NAME UNTRACE1 UNPARSE-LOGO-LINE VARIABLEP VERSION)
|
||
(SPECIAL :BURIED :CAREFUL :COMPILED :CONTENTS :EDITMODE :EMPTYW :ERRBREAK
|
||
:HISTORY :INFIX :LISPBREAK :NAMES :PARENBALANCE :PI :REDEFINE
|
||
:SCREENSIZE :SHOW :SNAPS :TEXT :TEXTXHOME :TEXTYHOME :WRAP ? ABB
|
||
ATOM-GOBBLER BAD-FORM CAR-FORM CDR-FORM CLOCK CLOGO CTRL-E CONTROL-K
|
||
CONTROL-L CTRL-P CTRL-R CTRL-S DEFAULT-PRECEDENCE DEFAULT-TURTLE
|
||
DEFINE-DEFPROP DEFINE-HOMCHECK DEFINE-OBTERN DEFINE-SYNONYMIZE
|
||
DEF-IND-RPLACA DEF-PROP-RPLACA DEF-SYM-RPLACA DPRINC DTERPRI
|
||
EDIT? EDITED EDITTITLE
|
||
EDL EDT EOF EOL EOL* ERRBREAK ERRLIST ERRS EXIT FIRST FLAG FN FNNAME
|
||
FULL GENSYM HOM HOMCHECK HOMCHECK-RPLACA INFIX INPUT-LIST INPUTS
|
||
INSERTLINE-NUMBER LAST-LINE LINE LISP LISP-OBARRAY LISP-OBDIM
|
||
LISPPRINT LISP-READTABLE LISPREADTABLE LOGO-OBARRAY LOGOREAD
|
||
LOGO-READTABLE LOGOREADTABLE MERGESTATUS NEXT-TAG NOUUO NO-VALUE
|
||
NULL-LINE NUMBER OBARRAY OBTERN-RPLACA OLD-LINE OLDPARSE PARSE
|
||
PARSED-FORM /11LOGO PASS2-LINE PI-OVER-180 PROG PROMPTER PROP
|
||
READTABLE REQUEST? REREAD-ERROR? RIGHT-ASSOCIATIVE SAIL STACK-TYPE SYN
|
||
SYN-NEW-RPLACA SYN-OLD-RPLACA TESTFLAG THIS-FORM THIS-FORM-INDEX
|
||
THIS-LINE THIS-LINE-INDEX THIS-VALUE-INDEX TITLE TOP-LINE TOKENLINE
|
||
TOL TOPARSE TTY TYPE UNPARSE UNPARSED-LINE UNARY-MINUS UP? WORD ^Q *
|
||
+ -)
|
||
(FIXNUM ABOVE ARGINDEX ARGS ARG-COUNT CHARNUM CHRCT DEFAULT-PRECEDENCE
|
||
DIRECTION ENV FORM-INDEX FRAME-NUMBER HOWMANY HOW-MANY-ARGS I J
|
||
LINE-INDEX LINEL LISP-OBDIM NEWLINEL POSITION (PRECEDENCE)
|
||
ROUND-FIXNUM-VARIABLE ROUND-PLACES STACK-POINTER
|
||
THIS-FORM-INDEX THIS-LINE-INDEX
|
||
THIS-VALUE-INDEX TYIPEEKED TTY VALUE-INDEX)
|
||
(ARRAY* (NOTYPE VALUE-HISTORY 1.)
|
||
(NOTYPE FORM-HISTORY 1.)
|
||
(NOTYPE LINE-HISTORY 1.)
|
||
(NOTYPE DEFINEARRAY-TYPE 1.))
|
||
(FLONUM (\$ FLONUM FLONUM) :PI PI-OVER-180 UNROUNDED TEN-TO-PLACES)
|
||
(NOTYPE (PARSE-EXPR-ARGS FIXNUM)))
|
||
|
||
;;*PAGE
|
||
|
||
;;; DEFINING LLOGO PRIMITIVES
|
||
;;;FORMAT - (DEFINE FN (11LOGO ...) (ABB ...) (SYN ...) (PARSE ...) (UNPARSE ...)
|
||
;; (FASLOAD ...) DEFINITION)
|
||
;;;
|
||
;;;(ABB ABB1 ABB2....) THIS CLAUSE SPECIFIES ABBREVIATIONS FOR THE FUNCTION BEING
|
||
;;DEFINED.
|
||
;;;(SYN GOLDEN-OLDIE) SAYS THAT THE FUNCTION IS TO BE DEFINED TO BE A SYNONYM OF
|
||
;;GOLDEN-OLDIE.
|
||
;;;(PARSE PARSE-PROPERTY) (UNPARSE UNPARSE-PROPERTY)
|
||
;;; ARE DECLARATIONS TO THE PARSER/UNPARSER TO SPECIFY HOW THE
|
||
;;; CALLS TO THE FUNCTION BEING DEFINED ARE TO BE PARSED/UNPARSED.
|
||
;;;(FASLOAD <FILE NAME>) -- FN IS DEFINED TO BE A MACRO WHICH WILL
|
||
;;; FASLOAD IN THE SPECIFIED FILE WHICH SHOULD DEFINE THE FN.
|
||
;;;; DEFINITION CONSISTS OF INPUTS AND BODY AS FOR A "DEFUN".
|
||
|
||
(DEFUN ACCEPT-ADVICE (ADVICE)
|
||
;;SLICE OFF ADVICE CLAUSES.
|
||
(DO NIL
|
||
((OR (NULL ADVICE)
|
||
(ATOM (CADR ADVICE))
|
||
(NOT (MEMQ (CAADR ADVICE) '(ABB SYN PARSE UNPARSE FASLOAD)))))
|
||
(SET (CAADR ADVICE) (CDADR ADVICE))
|
||
(RPLACD ADVICE (CDDR ADVICE))))
|
||
|
||
;;INITIALIZATION OF FORMS NEEDED BY DEFINE FUNCTION. THESE VARIABLES ARE KEPT
|
||
;;AROUND SO THAT DEFINE FUNCTION NEEDN'T DO CONSING.
|
||
|
||
(DEFUN DEFINE-PROPERTY (SYMBOL PROPERTY INDICATOR)
|
||
(DEFINE-HAPPEN (LIST 'DEFPROP SYMBOL PROPERTY INDICATOR)))
|
||
|
||
[(OR ITS DEC10) (DEFPROP DEFINE DEFINE-MACRO MACRO)]
|
||
|
||
[MULTICS (DEFPROP COUTPUT PUT-IN-TREE EXPR)]
|
||
|
||
(DEFUN [(OR ITS DEC10) DEFINE-MACRO
|
||
FEXPR] [MULTICS DEFINE
|
||
MACRO]
|
||
(X)
|
||
(PROG (FN SYN ABB UNPARSE PARSE FASLOAD)
|
||
(ACCEPT-ADVICE (SETQ X (CDR X)))
|
||
(SETQ FN (CAR X))
|
||
(COND ((OR FASLOAD (CDR X))
|
||
(DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE FN))))
|
||
((DEFINE-HAPPEN (LIST 'OBTERN
|
||
(LIST 'QUOTE FN)
|
||
'LOGO-OBARRAY))))
|
||
(AND PARSE (DEFINE-PROPERTY FN PARSE 'PARSE))
|
||
(AND UNPARSE (DEFINE-PROPERTY FN (CAR UNPARSE) 'UNPARSE))
|
||
(AND FASLOAD (DEFINE-PROPERTY FN FASLOAD 'AUTOLOAD))
|
||
(MAPC
|
||
'(LAMBDA (Y)
|
||
(DEFINE-HAPPEN (LIST 'HOMCHECK (LIST 'QUOTE Y)))
|
||
(DEFINE-PROPERTY Y
|
||
FN
|
||
[MULTICS 'EXPR]
|
||
[(OR ITS DEC10) (COND ((MEMQ (CADR X)
|
||
'(FEXPR MACRO))
|
||
'FEXPR)
|
||
('EXPR))]))
|
||
ABB)
|
||
(RETURN
|
||
(COND
|
||
(SYN (DEFINE-HAPPEN (LIST 'SYNONYMIZE
|
||
(LIST 'QUOTE FN)
|
||
(LIST 'QUOTE (CAR SYN))))
|
||
(LIST 'QUOTE (CAR SYN)))
|
||
((CDR X)
|
||
(SETQ X (CDR X))
|
||
(COND
|
||
((EQ (CAR X) 'MACRO)
|
||
((LAMBDA (COMPILED-MACRO)
|
||
(DEFINE-PROPERTY FN COMPILED-MACRO 'MACRO)
|
||
(LIST 'DEFPROP
|
||
COMPILED-MACRO
|
||
(CONS 'LAMBDA (CDR X))
|
||
'FEXPR))
|
||
(MAKNAM
|
||
(APPEND
|
||
'(D E F I N E - M A C R O -)
|
||
(EXPLODEC (SETQ DEFINE-MACRO-INDEX (1+ DEFINE-MACRO-INDEX)))))))
|
||
((CONS 'DEFUN (CONS FN X)))))))))
|
||
|
||
(SETQ DEFINE-MACRO-INDEX (FIX (TIME)))
|
||
|
||
;;*PAGE
|
||
|
||
|
||
(COND
|
||
((STATUS FEATURE LLOGO))
|
||
;;IF NOT READ INTO LLOGO, SUPPLY MISSING FUNCTIONS.
|
||
((DEFUN HOMCHECK (USELESS) USELESS)
|
||
(DEFUN OBTERN (USE LESS) USE)
|
||
(SETQ LOGO-OBARRAY NIL)
|
||
(DEFPROP ABB1 SYNONYMIZE EXPR)
|
||
(DEFUN SYNONYMIZE (NEW OLD)
|
||
(PUTPROP NEW
|
||
OLD
|
||
[MULTICS 'EXPR]
|
||
[(OR ITS DEC10) (COND ((GETL OLD '(EXPR SUBR LSUBR ARRAY))
|
||
'EXPR)
|
||
((GETL OLD '(FEXPR FSUBR))
|
||
'FEXPR)
|
||
((ERRBREAK 'DEFINE
|
||
'SYNONYM/ NOT/ FOUND)))]))
|
||
(DEFUN ERRBREAK ARGS
|
||
(PRINC (ARG 2.))
|
||
(TERPRI)
|
||
(APPLY 'BREAK (LIST (ARG 1.) T)))))
|
||
|
||
;;*PAGE
|
||
|
||
;;;IT'S MACRO TIME!
|
||
;;CAREFUL ABOUT USING THESE MACROS IN RANDOM FORMS, AS DEFINITIONS MAY NOT BE AROUND
|
||
;;AT RUN TIME.
|
||
|
||
(DECLARE (DEFPROP DEFINE-HAPPEN COUTPUT EXPR))
|
||
|
||
(DEFPROP DEFINE-HAPPEN EVAL EXPR)
|
||
|
||
(DEFINE SAVE-VERSION-NUMBER MACRO (CALL)
|
||
[(OR ITS DEC10) (LIST 'DEFPROP
|
||
(CADR CALL)
|
||
(CADR (STATUS UREAD))
|
||
'VERSION)]
|
||
[MULTICS (LIST 'DEFPROP
|
||
(CADR CALL)
|
||
(CADDAR (ALLFILES (LIST (CADR CALL) '*)))
|
||
'VERSION)])
|
||
|
||
(SAVE-VERSION-NUMBER DEFINE)
|
||
|
||
(DEFINE INCREMENT MACRO (CALL)
|
||
(RPLACA CALL 'SETQ)
|
||
(RPLACD CALL
|
||
(LIST (CADR CALL)
|
||
(CONS (COND ((NULL (CDDR CALL)) '1+) ('+))
|
||
(CDR CALL)))))
|
||
|
||
(DEFINE DECREMENT MACRO (CALL)
|
||
(RPLACA CALL 'SETQ)
|
||
(RPLACD CALL
|
||
(LIST (CADR CALL)
|
||
(CONS (COND ((NULL (CDDR CALL)) '1-) ('-))
|
||
(CDR CALL)))))
|
||
|
||
(DEFINE LET MACRO (CALL)
|
||
;;SYNTACTIC SUGAR FOR LOCAL LAMBDA BINDINGS. KEEPS BOUND VARIABLE AND BOUND
|
||
;;VALUE LEXICALLY NEAR EACH OTHER.
|
||
((LAMBDA (BOUND-VARIABLES BOUND-VALUES)
|
||
(MAPC '(LAMBDA (VARIABLE-SPEC)
|
||
(COND ((ATOM VARIABLE-SPEC)
|
||
(PUSH VARIABLE-SPEC BOUND-VARIABLES)
|
||
(PUSH NIL BOUND-VALUES))
|
||
((PUSH (CAR VARIABLE-SPEC) BOUND-VARIABLES)
|
||
(PUSH (CADR VARIABLE-SPEC) BOUND-VALUES))))
|
||
(CADR CALL))
|
||
(RPLACA CALL
|
||
(CONS 'LAMBDA
|
||
(CONS (NREVERSE BOUND-VARIABLES) (CDDR CALL))))
|
||
(RPLACD CALL (NREVERSE BOUND-VALUES)))
|
||
;;NOTICE HOW FAR AWAY VARIABLES ARE FROM VALUES!
|
||
NIL
|
||
NIL))
|
||
|
||
;;MACROS TO EXPAND BIT-TWIDDLING FUNCTIONS IN TERMS OF THE BOOLE FUNCTION.
|
||
;;PRIMARILY OF USE IN CONSTRUCTING MASKS FOR SETTING BITS IN THE TV BUFFER ARRAY.
|
||
|
||
(DEFINE BITWISE-AND MACRO (CALL) (RPLACA CALL 'BOOLE)
|
||
(RPLACD CALL (CONS 1. (CDR CALL))))
|
||
|
||
(DEFINE BITWISE-OR MACRO (CALL) (RPLACA CALL 'BOOLE)
|
||
(RPLACD CALL (CONS 7. (CDR CALL))))
|
||
|
||
(DEFINE BITWISE-NOT MACRO (CALL)
|
||
(RPLACA CALL 'BOOLE)
|
||
(RPLACD CALL (CONS 6. (CONS -1. (CDR CALL)))))
|
||
|
||
(DEFINE BITWISE-XOR MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 6. (CDR CALL))))
|
||
|
||
(DEFINE BITWISE-ANDC MACRO (CALL) (RPLACA CALL 'BOOLE) (RPLACD CALL (CONS 2. (CDR CALL))))
|
||
|
||
(DEFINE PROG1 MACRO (CALL)
|
||
;;USEFUL FOR KEEPING A VALUE AROUND MOMENTARILY AFTER
|
||
;;IT'S DESTROYED BY A SIDE EFFECT, WITHOUT CREATING
|
||
;;ANOTHER VARIABLE TO HOLD IT.
|
||
(RPLACA CALL 'PROG2)
|
||
(RPLACD CALL (CONS T (CDR CALL))))
|
||
|
||
(DEFINE ROUND MACRO (CALL)
|
||
(SUBST (CADR CALL)
|
||
'ROUND-ME
|
||
;;The ROUND-FIXNUM-VARIABLE crock is just an attempt to get the
|
||
;;compiler to open code the FIX. In general, FIX of a flonum may
|
||
;;return a BIGNUM.
|
||
'((LAMBDA (ROUND-FIXNUM-VARIABLE) ROUND-FIXNUM-VARIABLE)
|
||
(FIX (+$ ROUND-ME 0.5)))))
|
||
|
||
;;(CCONS 1 2 3) = (CONS 1 (CONS 2 3))
|
||
|
||
(DEFINE CCONS MACRO (X)
|
||
(RPLACA X 'CONS)
|
||
(AND (CDDDR X) (RPLACD X (LIST (CADR X) (CONS 'CCONS (CDDR X)))))
|
||
X)
|
||
|
||
;;REPLACES (PUSH X Y) BY (SETQ Y (CONS X Y))
|
||
|
||
(DEFINE PUSH MACRO (X)
|
||
(RPLACA X 'SETQ)
|
||
(RPLACD X (LIST (CADDR X) (LIST 'CONS (CADR X) (CADDR X)))))
|
||
|
||
;;REPLACES (POP X) BY (SETQ X (CDR X))
|
||
|
||
(DEFINE POP MACRO (X) (RPLACA X 'SETQ)
|
||
(RPLACD X (LIST (CADR X) (LIST 'CDR (CADR X)))))
|
||
|
||
|
||
(DEFINE REPEAT MACRO (CALL)
|
||
(SUBLIS (LIST (CONS 'REPEAT-ITERATIONS (CADR CALL))
|
||
(CONS 'REPEAT-BODY (CDDR CALL)))
|
||
'(DO ((REPEAT-COUNT 1. (1+ REPEAT-COUNT)))
|
||
((> REPEAT-COUNT REPEAT-ITERATIONS))
|
||
. REPEAT-BODY)))
|
||
|
||
|
||
;;END OF MACRO DEFINITIONS AND COMPILER DECLARATIONS. CHOOSE BETWEEN INTERPRETED
|
||
;;AND COMPILED DEFINITIONS OF DEFINE.
|
||
|
||
|
||
(DEFUN COMPILED-EXPR-FUNCTION FEXPR (CALL)
|
||
(RPLACA CALL 'GET)
|
||
(RPLACD CALL (LIST (LIST 'FUNCTION (CADR CALL)) ''SUBR)))
|
||
|
||
;;EXPR-FUNCTION & EXPR-CALL EXPAND INTO SUBRCALLS OF SUBR POINTERS FOR
|
||
;;EFFICIENCY, BUT INTERPRETIVELY ARE FUNCTION & FUNCALL.
|
||
|
||
(DEFUN COMPILED-EXPR-CALL FEXPR (CALL)
|
||
(RPLACA CALL 'SUBRCALL)
|
||
(RPLACD CALL (CONS NIL (CDR CALL))))
|
||
|
||
(DEFUN COMPILED-EXPR-CALL-FIXNUM FEXPR (CALL)
|
||
(RPLACA CALL 'SUBRCALL)
|
||
(RPLACD CALL (CONS 'FIXNUM (CDR CALL))))
|
||
|
||
(DEFUN INTERPRETIVE-EXPR-FUNCTION FEXPR (CALL)
|
||
(LET ((EXPR-FUNCTION-PROP (GETL (CADR CALL) '(SUBR EXPR-CALL-SUBR))))
|
||
;;A DUMMY SUBR MAY BE PUT UNDER THE PROPERTY EXPR-CALL-SUBR FOR
|
||
;;THE PURPOSE OF DEBUGGING INTERPRETIVELY.
|
||
(COND ((NULL EXPR-FUNCTION-PROP) (LIST 'FUNCTION (CADR CALL)))
|
||
((LIST 'QUOTE (CADR EXPR-FUNCTION-PROP))))))
|
||
|
||
(DEFUN INTERPRETIVE-EXPR-CALL FEXPR (CALL)
|
||
(LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
|
||
(LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
|
||
(COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL)
|
||
(CONS 'FUNCALL (CDR CALL)))
|
||
((CONS 'SUBRCALL (CONS NIL (CDR CALL))))))))
|
||
|
||
(DEFUN INTERPRETIVE-EXPR-CALL-FIXNUM FEXPR (CALL)
|
||
(LET ((EXPR-FUNCTION (EVAL (CADR CALL))))
|
||
(LET ((TYPE-EXPR-FUNCTION (TYPEP EXPR-FUNCTION)))
|
||
(COND ((EQ TYPE-EXPR-FUNCTION 'SYMBOL)
|
||
(CONS 'FUNCALL (CDR CALL)))
|
||
((CONS 'SUBRCALL (CONS 'FIXNUM (CDR CALL))))))))
|
||
|
||
(COND (COMPILING (DEFPROP EXPR-FUNCTION COMPILED-EXPR-FUNCTION MACRO)
|
||
(DEFPROP EXPR-CALL COMPILED-EXPR-CALL MACRO)
|
||
(DEFPROP EXPR-CALL-FIXNUM COMPILED-EXPR-CALL-FIXNUM MACRO))
|
||
((DEFPROP EXPR-FUNCTION INTERPRETIVE-EXPR-FUNCTION MACRO)
|
||
(DEFPROP EXPR-CALL INTERPRETIVE-EXPR-CALL MACRO)
|
||
(DEFPROP EXPR-CALL-FIXNUM INTERPRETIVE-EXPR-CALL-FIXNUM MACRO)))
|
||
|
||
|
||
(COND (COMPILING (DEFPROP DEFINE-HAPPEN COUTPUT EXPR))
|
||
;;FOR EXTRA FORMS TO BE MADE HAPPEN BY DEFINE FUNCTION, IF COMPILING, OUTPUT
|
||
;;THEM TO BE DONE AT RUN TIME, IF NOT COMPILING, JUST DO THEM.
|
||
((DEFPROP DEFINE-HAPPEN EVAL EXPR)))
|
||
|