github.com/PDP-10.its
1
0
Fork 0
mirror of https://github.com/PDP-10/its.git synced 2026-01-29 13:21:11 +00:00
Code Issues Releases Wiki Activity

Updated to build SHARPM FASL file from source.

Browse Source
This commit is contained in:
Eric Swenson
2016-12-23 17:57:59 -08:00
parent 5812ac3c3a
commit 728439320a
2 changed files with 496 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

495
src/nilcom/sharpm.82 Executable file
View File

@@ -0,0 +1,495 @@
;;; 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))))