;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; ;; - Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; ;; - Redistributions in binary form must reproduce the above copyright ;; notice, this list of conditions and the following disclaimer in ;; the documentation and/or other materials provided with the ;; distribution. ;; ;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the ;; names of its contributors may be used to endorse or promote products ;; derived from this software without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS ;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED ;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A ;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER ;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, ;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, ;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR ;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF ;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING ;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS ;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ; NAME: BootLex.lisp ; PURPOSE: Parsing support routines for Boot and Spad code ; CONTENTS: ; ; 0. Global parameters ; 1. BOOT File Handling ; 2. BOOT Line Handling ; 3. BOOT Token Handling ; 4. BOOT Token Parsing Actions ; 5. BOOT Error Handling (in-package "BOOT") ; *** 0. Global parameters (defparameter Boot-Line-Stack nil "List of lines returned from PREPARSE.") (defun Next-Lines-Clear () (setq Boot-Line-Stack nil)) (defun Next-Lines-Show () (and Boot-Line-Stack (format t "Currently preparsed lines are:~%~%")) (mapcar #'(lambda (line) (format t "~&~5D> ~A~%" (car line) (cdr Line))) Boot-Line-Stack)) ; *** 1. BOOT file handling (defun init-boot/spad-reader () (setq $SPAD_ERRORS (VECTOR 0 0 0)) (setq SPADERRORSTREAM *standard-output*) (setq XTokenReader 'get-BOOT-token) (setq Line-Handler 'next-BOOT-line) (setq Meta_Error_Handler 'spad_syntax_error) (setq File-Closed nil) (Next-Lines-Clear) (setq Boot-Line-Stack nil) (ioclear)) (defmacro test (x &rest y) `(progn (setq spaderrorstream t) (in-boot) (initialize-preparse *terminal-io*) (,(intern (strconc "PARSE-" x)) . ,y))) (defun |oldParserAutoloadOnceTrigger| () nil) (defun print-defun (name body) (let* ((sp (assoc 'compiler-output-stream optionlist)) (st (if sp (cdr sp) *standard-output*))) (if (and (is-console st) (symbolp name) (fboundp name) (not (compiled-function-p (symbol-function name)))) (compile name)) (when (or |$PrettyPrint| (not (is-console st))) (print-full body st) (force-output st)))) (defun boot-parse-1 (in-stream &aux (Echo-Meta nil) (current-fragment nil) ($INDEX 0) ($LineList nil) ($EchoLineStack nil) ($preparse-last-line nil) ($BOOT T) (*EOF* NIL) (OPTIONLIST NIL)) (declare (special echo-meta *comp370-apply* *EOF* File-Closed $index $linelist $echolinestack $preparse-last-line)) (init-boot/spad-reader) (let* ((Boot-Line-Stack (PREPARSE in-stream)) (parseout (prog2 (|PARSE-Expression|) (pop-stack-1)) ) ) ;(setq parseout (|new2OldLisp| parseout)) ; (setq parseout (DEF-RENAME parseout)) ; (DEF-PROCESS parseout) parseout)) (defun boot (&optional (*boot-input-file* nil) (*boot-output-file* nil) &aux (Echo-Meta t) ($BOOT T) (XCape #\_) (File-Closed NIL) (*EOF* NIL) (OPTIONLIST NIL) (*fileactq-apply* (function print-defun)) (*comp370-apply* (function print-defun))) (declare (special echo-meta *comp370-apply* *EOF* File-Closed XCape)) (setq |$InteractiveMode| NIL) (init-boot/spad-reader) (with-open-stream (in-stream (if *boot-input-file* (open *boot-input-file* :direction :input) *standard-input*)) (initialize-preparse in-stream) (with-open-stream (out-stream (if *boot-output-file* (open *boot-output-file* :direction :output) #-:cmulisp (make-broadcast-stream *standard-output*) #+:cmulisp *standard-output* )) (when *boot-output-file* (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") (print-package "BOOT")) (loop (if (and (not File-Closed) (setq Boot-Line-Stack (PREPARSE in-stream))) (progn (|PARSE-Expression|) (let ((parseout (pop-stack-1)) ) (setq parseout (|new2OldLisp| parseout)) (setq parseout (DEF-RENAME parseout)) (let ((*standard-output* out-stream)) (DEF-PROCESS parseout)) (format out-stream "~&") (if (null parseout) (ioclear)) )) (return nil))) (if *boot-input-file* (format out-stream ";;;Boot translation finished for ~a~%" (namestring *boot-input-file*))) (IOClear in-stream out-stream))) T) (defun spad (&optional (*spad-input-file* nil) (*spad-output-file* nil) &aux ;; (Echo-Meta *spad-input-file*) ;; (*comp370-apply* (function print-and-eval-defun)) (*comp370-apply* (function print-defun)) (*fileactq-apply* (function print-defun)) ($SPAD T) ($BOOT nil) (XCape #\_) (OPTIONLIST nil) (*EOF* NIL) (File-Closed NIL) ;; ($current-directory "/spad/libraries/") (/editfile *spad-input-file*) (|$noSubsumption| |$noSubsumption|) in-stream out-stream) (declare (special echo-meta /editfile *comp370-apply* *EOF* File-Closed Xcape |$noSubsumption|)) (setq |$InteractiveMode| nil) ;; only rebind |$InteractiveFrame| if compiling (progv (if (not |$InteractiveMode|) '(|$InteractiveFrame|)) (if (not |$InteractiveMode|) (list (|addBinding| '|$DomainsInScope| `((FLUID . |true|) (|special| . ,(COPY-TREE |$InitialDomainsInScope|))) (|addBinding| '|$Information| NIL (|makeInitialModemapFrame|))))) (init-boot/spad-reader) (unwind-protect (progn (setq in-stream (if *spad-input-file* (open *spad-input-file* :direction :input) *standard-input*)) (initialize-preparse in-stream) (setq out-stream (if *spad-output-file* (open *spad-output-file* :direction :output) *standard-output*)) (when *spad-output-file* (format out-stream "~&;;; -*- Mode:Lisp; Package:Boot -*-~%~%") (print-package "BOOT")) (setq curoutstream out-stream) (loop (if (or *eof* file-closed) (return nil)) (catch 'SPAD_READER (if (setq Boot-Line-Stack (PREPARSE in-stream)) (let ((LINE (cdar Boot-Line-Stack))) (declare (special LINE)) (|PARSE-NewExpr|) (let ((parseout (pop-stack-1)) ) (when parseout (let ((*standard-output* out-stream)) (S-PROCESS parseout)) (format out-stream "~&"))) ;(IOClear in-stream out-stream) ))) (IOClear in-stream out-stream))) (if *spad-input-file* (shut in-stream)) (if *spad-output-file* (shut out-stream))) T)) (defun READ-BOOT (FN FM TO) (let (($boot t)) (READ-SPAD1 FN 'BOOT FM TO))) (defun READ-SPAD1 (FN FT FM TO) (LET ((STRM IN-STREAM)) (SETQ $MAXLINENUMBER 0) (SETQ $SPAD_ERRORS (VECTOR 0 0 0)) (SETQ IN-STREAM (open (strconc fm ">" fn "." ft) :direction :input)) ($ERASE (LIST FN 'ERROR 'A)) (SETQ OUT-STREAM (if TO (open to :direction :output) OUT-STREAM)) (SETQ SPADERRORSTREAM (open (strconc "a>" fn ".error") :direction :output)) (READ-SPAD-1) (close SPADERRORSTREAM) (SETQ IN-STREAM STRM) (OR (EQUAL #(0 0 0) $SPAD_ERRORS) (|sayBrightly| (LIST '|%b| (ELT $SPAD_ERRORS 0) '|%d| '|syntax errors| '|%l| '|%b| (ELT $SPAD_ERRORS 1) '|%d| '|precompilation errors| '|%l| '|%b| (ELT $SPAD_ERRORS 2) '|%d| '|semantic errors| '|%l|))) (+ (ELT $SPAD_ERRORS 0) (ELT $SPAD_ERRORS 1) (ELT $SPAD_ERRORS 2)))) (defun READBOOT () (let (form expr ($BOOT 'T)) (declare (special $BOOT)) (ADVANCE-TOKEN) (|PARSE-Expression|) ;; (|pp| (setq form (|postTransform| (FIRST STACK)))) (|pp| (setq form (|postTransform| (pop-STACK-1)))) (setq EXPR (DEF-RENAME form)) (DEF-PROCESS EXPR) (TERSYSCOMMAND))) ; *** 2. BOOT Line Handling *** ; See the file PREPARSE.LISP for the hard parts of BOOT line processing. (defun next-BOOT-line (&optional (in-stream t)) "Get next line, trimming trailing blanks and trailing comments. One trailing blank is added to a non-blank line to ease between-line processing for Next Token (i.e., blank takes place of return). Returns T if it gets a non-blank line, and NIL at end of stream." (if Boot-Line-Stack (let ((Line-Number (caar Boot-Line-Stack)) (Line-Buffer (suffix #\Space (cdar Boot-Line-Stack)))) (pop Boot-Line-Stack) (Line-New-Line Line-Buffer Current-Line Line-Number) (setq |$currentLine| (setq LINE Line-Buffer)) Line-Buffer))) ; *** 3. BOOT Token Handling *** (defparameter xcape #\_ "Escape character for Boot code.") (defun get-BOOT-token (token) "If you have an _, go to the next line. If you have a . followed by an integer, get a floating point number. Otherwise, get a .. identifier." (if (not (boot-skip-blanks)) nil (let ((token-type (boot-token-lookahead-type (current-char)))) (case token-type (eof (token-install nil '*eof token nonblank)) (escape (advance-char) (get-boot-identifier-token token t)) (argument-designator (get-argument-designator-token token)) (id (get-boot-identifier-token token)) (num (get-number-token token)) (string (get-SPADSTRING-token token)) (special-char (get-special-token token)) (t (get-gliph-token token token-type)))))) (defun boot-skip-blanks () (setq nonblank t) (loop (let ((cc (current-char))) (if (not cc) (return nil)) (if (eq (boot-token-lookahead-type cc) 'white) (progn (setq nonblank nil) (if (not (advance-char)) (return nil))) (return t))))) (defun boot-token-lookahead-type (char) "Predicts the kind of token to follow, based on the given initial character." (cond ((not char) 'eof) ((char= char #\_) 'escape) ((and (char= char #\#) (digitp (next-char))) 'argument-designator) ((digitp char) 'num) ((and (char= char #\$) $boot (alpha-char-p (next-char))) 'id) ((or (char= char #\%) (char= char #\?) (char= char #\!) (alpha-char-p char)) 'id) ((char= char #\") 'string) ((member char '(#\Space #\Tab #\Return) :test #'char=) 'white) ((get (intern (string char)) 'Gliph)) (t 'special-char))) (defun get-argument-designator-token (token) (advance-char) (get-number-token token) (token-install (intern (strconc "#" (format nil "~D" (token-symbol token)))) 'argument-designator token nonblank)) (defvar Keywords '(|or| |and| |isnt| |is| |otherwise| |when| |where| |has| |with| |add| |case| |in| |by| |pretend| |mod| |exquo| |div| |quo| |else| |rem| |then| |suchthat| |if| |yield| |iterate| |from| |exit| |leave| |return| |not| |unless| |repeat| |until| |while| |for| |import|) "Alphabetic literal strings occurring in the New Meta code constitute keywords. These are recognized specifically by the AnyId production, GET-BOOT-IDENTIFIER will recognize keywords but flag them as keywords.") (defun get-boot-identifier-token (token &optional (escaped? nil)) "An identifier consists of an escape followed by any character, a %, ?, or an alphabetic, followed by any number of escaped characters, digits, or the chracters ?, !, ' or %" (prog ((buf (make-adjustable-string 0)) (default-package NIL)) (suffix (current-char) buf) (advance-char) id (let ((cur-char (current-char))) (cond ((char= cur-char XCape) (if (not (advance-char)) (go bye)) (suffix (current-char) buf) (setq escaped? t) (if (not (advance-char)) (go bye)) (go id)) ((and (null default-package) (char= cur-char #\')) (setq default-package buf) (setq buf (make-adjustable-string 0)) (if (not (advance-char)) (go bye)) (go id)) ((or (alpha-char-p cur-char) (digitp cur-char) (member cur-char '(#\% #\' #\? #\!) :test #'char=)) (suffix (current-char) buf) (if (not (advance-char)) (go bye)) (go id)))) bye (if (and (stringp default-package) (or (not (find-package default-package)) ;; not a package name (every #'(lambda (x) (eql x #\')) buf))) ;;token ends with '' (setq buf (concatenate 'string default-package "'" buf) default-package nil)) (setq buf (intern buf (or default-package "BOOT"))) (return (token-install buf (if (and (not escaped?) (member buf Keywords :test #'eq)) 'keyword 'identifier) token nonblank)))) (defun get-gliph-token (token gliph-list) (prog ((buf (make-adjustable-string 0))) (suffix (current-char) buf) (advance-char) loop (setq gliph-list (assoc (intern (string (current-char))) gliph-list)) (if gliph-list (progn (suffix (current-char) buf) (pop gliph-list) (advance-char) (go loop)) (let ((new-token (intern buf))) (return (token-install (or (get new-token 'renametok) new-token) 'gliph token nonblank)))))) (defun get-SPADSTRING-token (token) "With TOK=\" and ABC\" on IN-STREAM, extracts and stacks string ABC" (PROG ((BUF (make-adjustable-string 0))) (if (char/= (current-char) #\") (RETURN NIL) (advance-char)) (loop (if (char= (current-char) #\") (return nil)) (SUFFIX (if (char= (current-char) XCape) (advance-char) (current-char)) BUF) (if (null (advance-char)) ;;end of line (PROGN (|sayBrightly| "Close quote inserted") (RETURN nil))) ) (advance-char) (return (token-install (copy-seq buf) ;should make a simple string 'spadstring token)))) ; **** 4. BOOT token parsing actions ; Parsing of operator tokens depends on tables initialized by BOTTOMUP.LISP (defun-parse-token SPADSTRING) (defun-parse-token KEYWORD) (defun-parse-token ARGUMENT-DESIGNATOR) (defun TRANSLABEL (X AL) (TRANSLABEL1 X AL) X) (defun TRANSLABEL1 (X AL) "Transforms X according to AL = ((