From b8d7cd431a779551cf2c6eac94f6b4463db97273 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 10 Sep 2007 03:30:13 +0000 Subject: * Makefile.pamphlet (DEP): Adjust path to comp.lisp. (${DEPSYS}): Likewise for def.lisp, bootlex.lisp, postprop.lisp, metalex.lisp. Use |compileLispFile| instead of COMPILE-FILE. * Makefile.in: Regenerate. * union.lisp: New. * union.lisp.pamphlet: Move content to union.lisp. Remove. * obey.lisp: New. * obey.lisp.pamphlet: Move content to obey.lisp. Remove. * nspadaux.lisp: New. * nspadaux.lisp.pamphlet: Move content to nspadaux.lisp. Remove. * fname.lisp: New. * fname.lisp.pamphlet: Move content to fname.lisp. Remove. * def.lisp: New. * def.lisp.pamphlet: Move content to def.lisp. Remove. * comp.lisp: New. * comp.lisp.pamphlet: Move content to comp.lisp. Remove. * bootlex.lisp: New. * bootlex.lisp.pamphlet: Move content to bootlex.lisp. Remove. * postprop.lisp: New. * postprop.lisp.pamphlet: Move content to postprop.lisp. Remove. * metalex.lisp: New. * metalex.lisp.pamphlet: Move content to metalex.lisp. Remove. * parsing.lisp: New. * parsing.lisp.pamphlet: Move content to parsing.lisp. Remove. --- src/interp/bootlex.lisp.pamphlet | 475 --------------------------------------- 1 file changed, 475 deletions(-) delete mode 100644 src/interp/bootlex.lisp.pamphlet (limited to 'src/interp/bootlex.lisp.pamphlet') diff --git a/src/interp/bootlex.lisp.pamphlet b/src/interp/bootlex.lisp.pamphlet deleted file mode 100644 index 9913b93d..00000000 --- a/src/interp/bootlex.lisp.pamphlet +++ /dev/null @@ -1,475 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp bootlex.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; 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 'vmlisp::compiler-output-stream vmlisp::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 = ((