From 728439320a57d9f0b3fe4ef9ebcc726d99c0c935 Mon Sep 17 00:00:00 2001 From: Eric Swenson Date: Fri, 23 Dec 2016 17:57:59 -0800 Subject: [PATCH] Updated to build SHARPM FASL file from source. --- build/build.tcl | 1 + src/nilcom/sharpm.82 | 495 +++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 496 insertions(+) create mode 100755 src/nilcom/sharpm.82 diff --git a/build/build.tcl b/build/build.tcl index 0e8d4fb5..3a6ab0c7 100644 --- a/build/build.tcl +++ b/build/build.tcl @@ -791,6 +791,7 @@ respond "*" "complr\013" respond "_" "\007" respond "*" "(load '((lisp) subloa lsp))" respond "T" "(maklap)" +respond "_" "lisp;_nilcom;sharpm\r" respond "_" "lisp;_lspsrc;nilaid\r" respond "_" "\032" type ":kill\r" diff --git a/src/nilcom/sharpm.82 b/src/nilcom/sharpm.82 new file mode 100755 index 00000000..875e287a --- /dev/null +++ b/src/nilcom/sharpm.82 @@ -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: + ; ( ) + ; takes one argument, as described above [or () if none] + ; is either MACRO or SPLICING + ; is a flag which, if non-null, means don't flush the "second" + ; character from the input stream before running . + ; 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))))