mirror of
https://github.com/PDP-10/its.git
synced 2026-01-26 20:22:22 +00:00
496 lines
15 KiB
Common Lisp
Executable File
496 lines
15 KiB
Common Lisp
Executable File
;;; SHARPM -*-mode:lisp;package:si-*- -*-LISP-*-
|
||
;;; *************************************************************************
|
||
;;; ***** NIL ****** NIL/MACLISP/LISPM Compatible # Macro ******************
|
||
;;; *************************************************************************
|
||
;;; ******** (c) Copyright 1981 Massachusetts Institute of Technology *******
|
||
;;; ************ this is a read-only file! (all writes reserved) ************
|
||
;;; *************************************************************************
|
||
|
||
(herald SHARPM /82)
|
||
|
||
;;Note well: FORMAT versions > 700 use the list /#-SYMBOLIC-CHARACTERS-TABLE,
|
||
;; defined on the next page, to invert character names. For any given
|
||
;; character value, the first entry is used, so that should be the preferred
|
||
;; full name of the character. (The ordering by character code is gratuitous.)
|
||
|
||
(eval-when (eval compile)
|
||
(cond ((status feature MacLISP)
|
||
(or (get 'SUBLOAD 'VERSION)
|
||
(load '((lisp) subload)))
|
||
(setq USE-STRT7 'T)))
|
||
(cond ((or (not (status feature NIL))
|
||
(and (status feature NILAID)
|
||
(not (status feature FOR-NIL))))
|
||
(if (status feature COMPLR)
|
||
(special *:TRUTH /#-MACRO-DATALIST))
|
||
;;Canonical way to get at boolean truthity
|
||
(setq *:TRUTH 'T)
|
||
;;An A-list for associating readtables with their #-macro-datalists.
|
||
(if (or (not (boundp '/#-MACRO-DATALIST))
|
||
(null /#-MACRO-DATALIST))
|
||
(setq /#-MACRO-DATALIST (list `(,READTABLE . ()))))))
|
||
)
|
||
|
||
(eval-when (eval compile load)
|
||
(cond ((status feature MacLISP)
|
||
(cond ((and (status feature COMPLR) (fboundp '*lexpr))
|
||
(*lexpr SETSYNTAX-SHARP-MACRO)
|
||
(*expr SI:FEATUREP? SI:GET-FEATURE-SET))))
|
||
('T (globalize "DEFSHARP")
|
||
(globalize "SETSYNTAX-SHARP-MACRO")))
|
||
)
|
||
|
||
|
||
;;;;Defvar's
|
||
|
||
(defvar /#-SYMBOLIC-CHARACTERS-TABLE
|
||
'((NULL . 0)
|
||
(ALPHA . 2)
|
||
(BETA . 3)
|
||
(EPSILON . 6)
|
||
(BELL . 7.)
|
||
(BACKSPACE . 8.) (BS . 8)
|
||
(TAB . 9)
|
||
(LINEFEED . 10.) (LF . 10.)
|
||
(VT . 11.)
|
||
(FORM . 12.) (FORMFEED . 12.) (FF . 12.)
|
||
(RETURN . 13.) (NEWLINE . 13.) (CR . 13.) (NL . 13.)
|
||
(ALTMODE . 27.) (ALT . 27.)
|
||
(BACK-NEXT . 31.)
|
||
(SPACE . 32.) (SP . 32.)
|
||
(DELETE . 127.) (RUBOUT . 127.)
|
||
(HELP . 2120.)
|
||
))
|
||
|
||
|
||
(defvar |#-C-M-bits| '(128. 256. 384.)
|
||
"List of control and meta bits ;2^7, 2^8, 2^7+2^8 ")
|
||
|
||
|
||
(defvar TARGET-FEATURES 'LOCAL
|
||
"To allow for smooth interface to SHARPCONDITIONALS package.")
|
||
(defvar SI:FEATUREP? ()
|
||
"Used to communicate caller's function name to function SI:FEATUREP?")
|
||
|
||
(defvar SI:/#-TEST ()
|
||
"Used to block out certain errors if reading 'under' one of #N, #Q, or #M.")
|
||
|
||
|
||
;;;; Temporary MACROS and "Scotch-tape"
|
||
|
||
|
||
(eval-when (eval compile)
|
||
|
||
(setq defmacro-for-compiling () )
|
||
|
||
(cond ((or (not (status feature NIL))
|
||
(and (status feature NILAID)
|
||
(not (status feature FOR-NIL))))
|
||
(defsimplemac CHARACTER (c)
|
||
`(CASEQ (TYPEP ,c)
|
||
(FIXNUM ,c)
|
||
(SYMBOL (GETCHARN ,c 1))
|
||
(T (ERROR "Not a character - CHARACTER" ,c))))
|
||
(defmacro *:FIXNUM-TO-CHARACTER (x) x)
|
||
(defmacro CHARACTERIFY (x) x)
|
||
(defmacro CHARACTERIZE (x) `(ASCII ,x))
|
||
(defmacro /#SUB-READ (&rest x) x '(READ))
|
||
(defmacro READ-TOKEN (simplep ttt b () )
|
||
`(*read-token ,simplep ,(and (eq ttt '~*) ''*) ,b () ))
|
||
(defmacro READTABLE-sharp-macro-list (x)
|
||
`(CDR (ASSOC ,x /#-MACRO-DATALIST)))
|
||
(defmacro /#TYI (&rest ()) `(TYI))
|
||
(defmacro /#TYIPEEK (&rest ()) `(TYIPEEK)))
|
||
('T
|
||
(defvar NON-DECDIGIT-TABLE ()
|
||
"Should be set up by READER.")
|
||
(defmacro /#SUB-READ (&rest x)
|
||
;;In order to "bootstrap"-read this file, we must start out using
|
||
;; maclisp's old reader - when it is fully in, then the definition
|
||
;; of /#SUB-READ is changed to be SUB-READ
|
||
(cond ((and (status feature NILAID)
|
||
(not (status feature FOR-NIL)))
|
||
`(OLD-READ)) ;bootstrap case, with NILAID
|
||
('T `(SUB-READ ,.x))) ;standard NIL case
|
||
)
|
||
(defmacro CHARACTERIFY (x) `(*:FIXNUM-TO-CHARACTER ,x))
|
||
(defmacro CHARACTERIZE (x) `(*:FIXNUM-TO-CHARACTER ,x))
|
||
(defmacro /#TYI (&rest w) `(*:CHARACTER-TO-FIXNUM (READER-INCH ,.w)))
|
||
(defmacro /#TYIPEEK (&rest w)
|
||
`(*:CHARACTER-TO-FIXNUM (READER-INCHPEEK ,.w)))))
|
||
|
||
(setq defmacro-for-compiling 'T)
|
||
|
||
)
|
||
|
||
|
||
|
||
;;;; DEFSHARP and SETSYNTAX-SHARP-MACRO
|
||
|
||
(eval-when (eval compile)
|
||
(setq defmacro-for-compiling 'T defmacro-displace-call () )
|
||
(and (status feature MacLISP)
|
||
(status feature COMPLR)
|
||
(own-symbol SETSYNTAX-SHARP-MACRO DEFSHARP))
|
||
)
|
||
|
||
(defmacro DEFSHARP (C &REST BODY)
|
||
(LET ((NAME (IMPLODE (APPEND '(/# - M A C R O -) (LIST C))))
|
||
(IND (COND ((MEMQ (CAR BODY)
|
||
'(MACRO SPLICING PEEK PEEK-MACRO PEEK-SPLICING))
|
||
(PROG2 () (CAR BODY) (SETQ BODY (CDR BODY))))
|
||
('MACRO))))
|
||
;Standardize on character representation as fixnum
|
||
`(PROGN 'COMPILE
|
||
(DEFUN ,name ,. body)
|
||
(SETSYNTAX-SHARP-MACRO ',c ',ind ',name))))
|
||
|
||
|
||
(defun SETSYNTAX-SHARP-MACRO (C IND FUN &OPTIONAL (RT READTABLE) )
|
||
(declare (special READTABLE))
|
||
(LET ((SPLICEP (IF (MEMQ IND '(SPLICING PEEK-SPLICING))
|
||
'SPLICING
|
||
'MACRO))
|
||
(PEEKP (AND (MEMQ IND '(PEEK PEEK-MACRO PEEK-SPLICING)) 'T))
|
||
(MDL (prog2 (if (and (status feature MacLISP)
|
||
(null (assoc rt /#-MACRO-DATALIST)))
|
||
(push `(,rt . () ) /#-MACRO-DATALIST))
|
||
(READTABLE-sharp-macro-list RT))))
|
||
(SETQ C (CHARACTER C))
|
||
;;Upper-casify if necessary
|
||
(AND (NOT (< C #/a))
|
||
(NOT (> C #/z))
|
||
(SETQ C (- C (- #/a #/A))))
|
||
(SETQ C (CHARACTERIFY C))
|
||
;;Delete any previous entries
|
||
(DO ((Y (ASSOC C MDL) (ASSOC C MDL)))
|
||
((NULL Y))
|
||
(SETQ MDL (DELQ Y MDL)))
|
||
(AND FUN (PUSH `(,c ,peekp ,splicep . ,fun) MDL))
|
||
(SETF (READTABLE-sharp-macro-list RT) MDL)
|
||
FUN))
|
||
|
||
|
||
;;;; +INTERNAL-/#-MACRO and helpers
|
||
|
||
(eval-when (compile)
|
||
(and (status feature MacLISP)
|
||
(own-symbol +INTERNAL-/#-MACRO /#+--TEST-FOR-FEATURE
|
||
/#-CNTRL-META-IFY /#-FLUSH-CHARS-NOT-SET ))
|
||
)
|
||
|
||
;The # macro works by keying off a second character, with possibly an
|
||
; argument in between. Currently, the permissible arguments are
|
||
; (1) digits, for a numeric argument
|
||
; (2) ^B, ^C, or ^F to signify "add control, meta, or control-meta"
|
||
;The alist from /#-MACRO-DATALIST holds for each valid "second" character
|
||
; a 4-list:
|
||
; (<char-code> <peekp> <type> <function>)
|
||
; <function> takes one argument, as described above [or () if none]
|
||
; <type> is either MACRO or SPLICING
|
||
; <peekp> is a flag which, if non-null, means don't flush the "second"
|
||
; character from the input stream before running <function>.
|
||
; <char-code> is the numeric encodeing of the character
|
||
|
||
|
||
(eval-when (eval compile)
|
||
(if (status feature MacLISP)
|
||
(defmacro make-/#-macro-fun ()
|
||
'(DEFUN +INTERNAL-/#-MACRO ()
|
||
(SI:/#-MACRO-1 () )))
|
||
(defmacro make-/#-macro-fun ()
|
||
'(DEFUN +INTERNAL-/#-MACRO (C S)
|
||
(AND (OR (NOT (EQ C ~/#)) (NOT (EQ S READ-STREAM)))
|
||
(READER-ERROR S))
|
||
(SI:/#-MACRO-1 S))))
|
||
)
|
||
|
||
(make-/#-macro-fun)
|
||
|
||
(defun SI:/#-MACRO-1 (S)
|
||
(declare (special READTABLE)
|
||
(fixnum c))
|
||
(LET ((C (/#TYIPEEK S))
|
||
(MDL (READTABLE-sharp-macro-list READTABLE) )
|
||
MACRO-ARG PEEKP MACRO-TYPE MACRO-FUN UC TMP)
|
||
;;MACRO-ARG accumulates an "infix" argument, like a number in the
|
||
;; #16R... case. The argument is the item between the "#" and
|
||
;; the dispatchable character.
|
||
(IF (COND ((<= #/0 C #/9)
|
||
(SETQ MACRO-ARG (READ-TOKEN 'FIXNUMP NON-DECDIGIT-TABLE 10. S))
|
||
'T)
|
||
((SETQ MACRO-ARG (CASEQ C
|
||
(2 (/#TYI S) 'CONTROL) ;#/ (alpha)
|
||
(3 (/#TYI S) 'META) ;#/ (beta)
|
||
(6 (/#TYI S) 'CONTROL-META) ;#/ (epsilon)
|
||
(T () )))
|
||
'T))
|
||
(SETQ C (/#TYIPEEK S)))
|
||
;;Find flags/function for this character
|
||
(SETQ UC (if (AND (NOT (< C #/a)) (NOT (> C #/z)))
|
||
;;Upper-casify if necessary
|
||
(- C (- #/a #/A))
|
||
C))
|
||
(SETQ UC (CHARACTERIFY UC))
|
||
(COND ((SETQ TMP (ASSOC UC MDL)))
|
||
('T (/#TYI S) ;flush the character
|
||
(ERROR '|Unknown dispatch character after #|
|
||
(CHARACTERIZE C))))
|
||
(DESETQ ( () PEEKP MACRO-TYPE . MACRO-FUN ) TMP)
|
||
(AND (OR (NULL MACRO-FUN)
|
||
(NOT (MEMQ MACRO-TYPE '(MACRO SPLICING))))
|
||
(ERROR '"Garbage format in #-MACRO-DATALIST" (CHARACTERIZE C)))
|
||
(AND (NOT PEEKP) (/#TYI S))
|
||
(SETQ MACRO-ARG (FUNCALL MACRO-FUN MACRO-ARG))
|
||
(CASEQ MACRO-TYPE
|
||
(MACRO (LIST MACRO-ARG))
|
||
(SPLICING MACRO-ARG))))
|
||
|
||
|
||
;;;; Helper funs
|
||
|
||
(DEFUN /#+--TEST-FOR-FEATURE (F)
|
||
(COND ((ATOM F)
|
||
(MEMQ F (STATUS FEATURES)))
|
||
((EQ (CAR F) 'NOT)
|
||
(IF (OR (NULL (CDR F)) ; Disallow #+(NOT)
|
||
(CDDR F)) ; Disallow #+(NOT f1 f2 ...)
|
||
(ERROR '|Bad features list for #+ or #-| F))
|
||
(NOT (/#+--TEST-FOR-FEATURE (CADR F))))
|
||
((EQ (CAR F) 'AND)
|
||
(do ((l (cdr f) (cdr l)))
|
||
((null l) 'T)
|
||
(if (not (/#+--TEST-FOR-FEATURE (car l)))
|
||
(return () ))))
|
||
((EQ (CAR F) 'OR)
|
||
(do ((l (cdr f) (cdr l)))
|
||
((null l) () )
|
||
(if (/#+--TEST-FOR-FEATURE (car l))
|
||
(return 'T))))
|
||
;If we ever decide to make #+(MACLISP BIBOP) default
|
||
; to anything, here is the place to do it
|
||
('T (ERROR '|Bad features list for #+ or #-| F))))
|
||
|
||
|
||
(DEFUN /#-CNTRL-META-IFY (MACRO-ARG N CHAR)
|
||
(COND ((NULL MACRO-ARG) N)
|
||
((EQ MACRO-ARG 'CONTROL) (+ N (CAR |#-C-M-bits|))) ;Cntrl bit
|
||
((EQ MACRO-ARG 'META) (+ N (CADR |#-C-M-bits|))) ;Meta bit
|
||
((EQ MACRO-ARG 'CONTROL-META) (+ N (CADDR |#-C-M-bits|))) ;Both bits
|
||
('T (ERROR '|Bad argument to a # function|
|
||
(LIST MACRO-ARG CHAR)))))
|
||
|
||
|
||
|
||
(eval-when (eval compile)
|
||
|
||
(cond ((or (not (status feature NIL))
|
||
(and (status feature NILAID)
|
||
(not (status feature FOR-NIL))))
|
||
(defmacro make-non-NIL-helper-funs ()
|
||
`(progn 'compile
|
||
|
||
(defun |#-MACRO-T| (() ) ;#T is "truthity", not false
|
||
(if (and (not (status feature NIL))
|
||
(not (eq SI:/#-TEST 'N)))
|
||
(error '|Unknown dispatch character after #| 'T))
|
||
*:TRUTH)
|
||
;; An open-coding of DEFSHARP, with added crinkle about EXTEND package
|
||
(or (and (get 'EXTEND 'VERSION)
|
||
(assoc #/T (READTABLE-sharp-macro-list READTABLE)))
|
||
(setsyntax-sharp-macro #/T 'MACRO '|#-MACRO-T|))
|
||
|
||
|
||
(defun *READ-TOKEN (simplep gobble-terminatorp b () )
|
||
(declare (fixnum n c b*))
|
||
(and (or (not (eq (typep b) 'FIXNUM))
|
||
(< b 1)
|
||
(> b 36.)
|
||
(not (memq simplep '(FIXNUMP NUMBERP))))
|
||
(+internal-lossage () '*READ-TOKEN (list simplep b)))
|
||
(caseq simplep
|
||
(FIXNUMP
|
||
(do ((c (tyipeek) (tyipeek))
|
||
(n 0 (+ (- c #/0)
|
||
(if (eq gobble-terminatorp '*)
|
||
;; losing #*...* format is octal
|
||
(lsh n 3)
|
||
(* n b))))
|
||
(b* (+ b #/0)))
|
||
((or (< c #/0) (not (< c b*)))
|
||
(and gobble-terminatorp (tyi))
|
||
n)
|
||
(tyi)))
|
||
(NUMBERP
|
||
(let ((save (status /+)) (ibase b) ans)
|
||
(setq ans (cond (save (read))
|
||
((unwind-protect
|
||
(prog2 (sstatus /+ 'T ) (read))
|
||
(sstatus /+ save)))))
|
||
(or (numberp ans)
|
||
(error '"Numeric token expected by some #-function" ans))
|
||
ans))))
|
||
|
||
(defsharp /: splicing (() ) (/#-flush-chars-not-set #/: 'T) () )
|
||
|
||
(defun /#-flush-chars-not-set (s finalp)
|
||
(do ((c (tyipeek) (tyipeek))
|
||
(fixp (eq (typep s) 'fixnum)))
|
||
((cond (fixp (= c s))
|
||
((member c s)))
|
||
(and finalp (tyi))
|
||
(list () ))
|
||
(and (= c #//) (tyi))
|
||
(tyi)))
|
||
|
||
|
||
(defun /#-bs-reader (x lbb char)
|
||
;; "lbb" is Log-Binary-Base; e.g. 1 for binary, 3 for octal, and 4 for hex
|
||
(and x (error '|Bad argument to a # function| (list '/# char x)))
|
||
(cond ((not (= (tyipeek) #/"))
|
||
(read-token 'NUMBERP
|
||
token-terminator-table
|
||
(^ 2 lbb)
|
||
() ))
|
||
('T (/#-/#B-reader lbb))))
|
||
|
||
(if (status feature MacLISP)
|
||
(def-or-autoloadable /#-/#B-reader BITS))
|
||
|
||
)))
|
||
|
||
('T (defmacro make-non-NIL-helper-funs ()
|
||
`(defsharp #/T (() ) *:TRUTH)))
|
||
))
|
||
|
||
(make-non-NIL-helper-funs)
|
||
|
||
|
||
|
||
;;;; Lesser used sharps
|
||
|
||
|
||
;;; "controlify", which for 7-bit ascii means just to complement the 100 bit.
|
||
(defsharp /^ (() )
|
||
(let ((c (tyi)))
|
||
(or (< c #/a) ;lower case "a"
|
||
(> c #/z) ;lower case "z"
|
||
(setq c (- c (- #/a #/A))))
|
||
(boole 6 1_6 c)))
|
||
|
||
|
||
(defsharp /* (() ) (read-token 'FIXNUMP ~* 8 READ-STREAM))
|
||
|
||
(defsharp /| SPLICING (() )
|
||
(prog (n )
|
||
(declare (fixnum n))
|
||
(setq n 0)
|
||
(go home)
|
||
sharp (caseq (/#tyi READ-STREAM)
|
||
(#/# (go sharp))
|
||
(#/| (setq n (1+ n)))
|
||
(#// (/#tyi READ-STREAM))
|
||
(-1 (go barf)))
|
||
home (caseq (/#tyi READ-STREAM)
|
||
(#/| (go bar))
|
||
(#/# (go sharp))
|
||
(#// (/#tyi READ-STREAM)
|
||
(go home))
|
||
(-1 (go barf))
|
||
(T (go home)))
|
||
bar (caseq (/#tyi READ-STREAM)
|
||
(#/# (cond ((= n 0) (return () ))
|
||
(T (setq n (1- n))
|
||
(go home))))
|
||
(#/| (go bar))
|
||
(#// (/#tyi READ-STREAM)
|
||
(go home))
|
||
(-1 (go barf))
|
||
(T (go home)))
|
||
barf (error () "EOF within read of # comment")))
|
||
|
||
(defsharp /R (macro-arg)
|
||
(if (or (not (eq (typep macro-arg) 'FIXNUM))
|
||
(< macro-arg 1)
|
||
(> macro-arg 36.))
|
||
(error "Bad numeric base for #nR" macro-arg))
|
||
(read-token 'NUMBERP
|
||
token-terminator-table
|
||
macro-arg
|
||
read-stream))
|
||
|
||
(defsharp /B (c) ;#B"..." for BITS's in binary form
|
||
(/#-bs-reader c 1 'B))
|
||
|
||
|
||
;;;; Common /# macros - definitions
|
||
|
||
(defsharp /' (() ) `(FUNCTION ,(/#sub-read () READ-STREAM)))
|
||
|
||
(defsharp // (macro-arg) (/#-cntrl-meta-ify macro-arg (tyi) '//))
|
||
|
||
(defsharp /% (() ) (macroexpand (/#sub-read () READ-STREAM)))
|
||
|
||
(defsharp /. (() ) (eval (/#sub-read () READ-STREAM)))
|
||
|
||
(defsharp /, (() )
|
||
(let ((form (/#sub-read () READ-STREAM)))
|
||
(declare (special squid))
|
||
(cond ((memq COMPILER-STATE '(NIL () TOPLEVEL))
|
||
(eval form))
|
||
('T `(,squid ,form)))))
|
||
|
||
(defsharp /\ (macro-arg)
|
||
(let ((n (/#-/\-parse)))
|
||
(/#-cntrl-meta-ify macro-arg n '/\)))
|
||
|
||
(defun /#-/\-parse ()
|
||
(let* ((ob (/#sub-read () READ-STREAM))
|
||
(n (do ((l (and (symbolp ob) /#-SYMBOLIC-CHARACTERS-TABLE) (cdr l)))
|
||
((null l) () )
|
||
(and (samepnamep ob (caar l)) (return (cdar l))))))
|
||
(and (null n)
|
||
(caseq SI:/#-TEST
|
||
(M (status feature MacLISP))
|
||
(Q (status feature LISPM))
|
||
(N (status feature NIL)))
|
||
(error '"Unknown symbolic name to #\" ob))
|
||
n))
|
||
|
||
|
||
|
||
(defsharp /+ SPLICING (())
|
||
(si:/#+or-read (/#sub-read () READ-STREAM) 'T () ))
|
||
|
||
(defsharp /- SPLICING (())
|
||
(si:/#+or-read (/#sub-read () READ-STREAM) () () ))
|
||
|
||
(defun SI:/#+OR-READ (features polarity SI:/#-TEST)
|
||
(if (null SI:/#-TEST)
|
||
(let ((z (assq features '((MacLISP . M) (LISPM . Q) (NIL . N)))))
|
||
(if z (setq SI:/#-TEST (cdr z)))))
|
||
(let ((form (/#sub-read () READ-STREAM)))
|
||
(if (cond ((get 'SHARPCONDITIONALS 'VERSION)
|
||
(let ((SI:FEATUREP? 'SI:/#+OR-READ))
|
||
(si:featurep?
|
||
features
|
||
(si:get-feature-set TARGET-FEATURES 'SI:/#+OR-READ)
|
||
polarity)))
|
||
((/#+--test-for-feature features) polarity)
|
||
('T (not polarity)))
|
||
(list form))))
|
||
|
||
|
||
(defsharp /M SPLICING (()) (SI:/#+OR-READ 'MacLISP 'T 'M))
|
||
(defsharp /N SPLICING (()) (SI:/#+OR-READ 'NIL 'T 'N))
|
||
(defsharp /Q SPLICING (()) (SI:/#+OR-READ 'LISPM 'T 'Q))
|
||
|
||
(defsharp /O (c) (/#-bs-reader c 3 'O))
|
||
(defsharp /X (c) (/#-bs-reader c 4 'X))
|
||
|
||
(cond ((status feature MacLISP)
|
||
(defprop function (lambda () (readmacroinverse |#'|)) grindmacro)
|
||
(defprop function readmacroinverse-predict grindpredict)
|
||
(or (status macro /#)
|
||
(setsyntax '/# 'SPLICING '+INTERNAL-/#-MACRO))))
|