diff options
author | dos-reis <gdr@axiomatics.org> | 2011-10-07 19:48:11 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2011-10-07 19:48:11 +0000 |
commit | 16e12e0c3d18a3eb41425be40275236c6df37c40 (patch) | |
tree | 82d380fb5e2e6d0d48f3b918d5aaafa20115f3f9 /src/interp | |
parent | da334a99fa9e66215133f4cf5fe87a3b78d7084e (diff) | |
download | open-axiom-16e12e0c3d18a3eb41425be40275236c6df37c40.tar.gz |
* interp/lexing.boot: Include sys-macros.
Add more tokenizer functions.
* interp/fnewmeta.lisp: Use them.
* interp/parsing.lisp: Likewise.
* interp/bootlex.lisp: Likewise.
* interp/spad.lisp: Likewise.
(NEXT-BOOT-LINE): Remove.
* interp/metalex.lisp: Remove old lexing routines.
* interp/Makefile.in (lexing.$(FASLEXT)): Adjust dependency.
* boot/tokens.boot: newString is no longer builtin library function.
(shoeDictCons): Use makeString not newString.
* lisp/core.lisp.in (listToString): Fix typo.
Diffstat (limited to 'src/interp')
-rw-r--r-- | src/interp/Makefile.in | 2 | ||||
-rw-r--r-- | src/interp/bootlex.lisp | 101 | ||||
-rw-r--r-- | src/interp/fnewmeta.lisp | 24 | ||||
-rw-r--r-- | src/interp/lexing.boot | 161 | ||||
-rw-r--r-- | src/interp/metalex.lisp | 332 | ||||
-rw-r--r-- | src/interp/parsing.lisp | 36 | ||||
-rw-r--r-- | src/interp/spad.lisp | 6 |
7 files changed, 253 insertions, 409 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 79e21ea0..8f6feade 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -335,7 +335,7 @@ parsing.$(FASLEXT): metalex.$(FASLEXT) metalex.$(FASLEXT): lexing.$(FASLEXT) macros.$(FASLEXT) nlib.$(FASLEXT): macros.$(FASLEXT) macros.$(FASLEXT): sys-macros.$(FASLEXT) sys-utility.$(FASLEXT) -lexing.$(FASLEXT): sys-utility.$(FASLEXT) +lexing.$(FASLEXT): sys-utility.$(FASLEXT) sys-macros.$(FASLEXT) ## The new parser component roughtly is: ## astr.boot dq.boot incl.boot pile.boot ptrees.boot diff --git a/src/interp/bootlex.lisp b/src/interp/bootlex.lisp index bda374de..328aced3 100644 --- a/src/interp/bootlex.lisp +++ b/src/interp/bootlex.lisp @@ -58,7 +58,7 @@ (setq SPADERRORSTREAM |$OutputStream|) (setq File-Closed nil) (Next-Lines-Clear) - (setq Boot-Line-Stack nil) + (setq |$lineStack| nil) (ioclear)) (defmacro test (x &rest y) @@ -118,8 +118,8 @@ (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))) + (if (setq |$lineStack| (PREPARSE in-stream)) + (let ((LINE (cdar |$lineStack|))) (declare (special LINE)) (|PARSE-NewExpr|) (let ((parseout (|popStack1|)) ) @@ -152,25 +152,6 @@ (+ (ELT $SPAD_ERRORS 0) (ELT $SPAD_ERRORS 1) (ELT $SPAD_ERRORS 2)))) -; *** 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 *** (defun get-BOOT-token (token) @@ -181,10 +162,10 @@ Otherwise, get a .. identifier." (if (not (boot-skip-blanks)) nil - (let ((token-type (boot-token-lookahead-type (current-char)))) + (let ((token-type (boot-token-lookahead-type (|currentChar|)))) (case token-type (eof (|tokenInstall| nil '*eof token |$nonblank|)) - (escape (advance-char) + (escape (|advanceChar!|) (get-boot-identifier-token token t)) (argument-designator (get-argument-designator-token token)) (id (get-boot-identifier-token token)) @@ -195,20 +176,20 @@ Otherwise, get a .. identifier." (defun boot-skip-blanks () (setq |$nonblank| t) - (loop (let ((cc (current-char))) + (loop (let ((cc (|currentChar|))) (if (not cc) (return nil)) (if (eq (boot-token-lookahead-type cc) 'white) - (progn (setq |$nonblank| nil) (if (not (advance-char)) (return nil))) + (progn (setq |$nonblank| nil) (if (not (|advanceChar!|)) (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) + ((and (char= char #\#) (digitp (|nextChar|))) 'argument-designator) ((digitp char) 'num) ((and (char= char #\$) $boot - (alpha-char-p (next-char))) 'id) + (alpha-char-p (|nextChar|))) 'id) ((or (char= char #\%) (char= char #\?) (char= char #\!) (alpha-char-p char)) 'id) ((char= char #\") 'string) @@ -219,7 +200,7 @@ Otherwise, get a .. identifier." (t 'special-char))) (defun get-argument-designator-token (token) - (advance-char) + (|advanceChar!|) (get-number-token token) (|tokenInstall| (intern (strconc "#" (format nil "~D" (|tokenSymbol| token)))) 'argument-designator token |$nonblank|)) @@ -231,26 +212,26 @@ 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))) + (suffix (|currentChar|) buf) + (|advanceChar!|) + id (let ((cur-char (|currentChar|))) (cond ((char= cur-char #\_) - (if (not (advance-char)) (go bye)) - (suffix (current-char) buf) + (if (not (|advanceChar!|)) (go bye)) + (suffix (|currentChar|) buf) (setq escaped? t) - (if (not (advance-char)) (go bye)) + (if (not (|advanceChar!|)) (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)) + (if (not (|advanceChar!|)) (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)) + (suffix (|currentChar|) buf) + (if (not (|advanceChar!|)) (go bye)) (go id)))) bye (if (and (stringp default-package) (or (not (find-package default-package)) ;; not a package name @@ -261,20 +242,20 @@ or the chracters ?, !, ' or %" (return (|tokenInstall| buf (if (and (not escaped?) - (member buf Keywords :test #'eq)) + (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)) + (suffix (|currentChar|) buf) + (|advanceChar!|) + loop (setq gliph-list (assoc (intern (string (|currentChar|))) gliph-list)) (if gliph-list - (progn (suffix (current-char) buf) + (progn (suffix (|currentChar|) buf) (pop gliph-list) - (advance-char) + (|advanceChar!|) (go loop)) (let ((new-token (intern buf))) (return (|tokenInstall| (or (get new-token 'renametok) new-token) @@ -283,17 +264,17 @@ or the chracters ?, !, ' or %" (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)) + (if (char/= (|currentChar|) #\") (RETURN NIL) (|advanceChar!|)) (loop - (if (char= (current-char) #\") (return nil)) - (SUFFIX (if (char= (current-char) #\_) - (advance-char) - (current-char)) + (if (char= (|currentChar|) #\") (return nil)) + (SUFFIX (if (char= (|currentChar|) #\_) + (|advanceChar!|) + (|currentChar|)) BUF) - (if (null (advance-char)) ;;end of line + (if (null (|advanceChar!|)) ;;end of line (PROGN (|sayBrightly| "Close quote inserted") (RETURN nil))) ) - (advance-char) + (|advanceChar!|) (return (|tokenInstall| (copy-seq buf) ;should make a simple string 'spadstring token)))) @@ -307,10 +288,10 @@ or the chracters ?, !, ' or %" ;; value. (defun get-decimal-number-token (buf) (tagbody lp - (suffix (current-char) buf) - (let ((next-chr (next-char))) + (suffix (|currentChar|) buf) + (let ((next-chr (|nextChar|))) (cond ((digitp next-chr) - (advance-char) + (|advanceChar!|) (go lp))))) (parse-integer buf)) @@ -322,13 +303,13 @@ or the chracters ?, !, ' or %" (spad_syntax_error)) (let ((mark (1+ (size buf)))) (tagbody lp - (suffix (current-char) buf) - (let* ((nxt (next-char)) + (suffix (|currentChar|) buf) + (let* ((nxt (|nextChar|)) (dig (|rdigit?| nxt))) (when dig (unless (< dig r) (spad_syntax_error)) - (advance-char) + (|advanceChar!|) (go lp)))) (parse-integer buf :start mark :radix r))) @@ -341,10 +322,10 @@ or the chracters ?, !, ' or %" (defun get-spad-integer-token (token) (let* ((buf (make-adjustable-string 0)) (val (get-decimal-number-token buf))) - (advance-char) - (when (is-radix-char (current-char)) + (|advanceChar!|) + (when (is-radix-char (|currentChar|)) (setq val (get-integer-in-radix buf val)) - (advance-char)) + (|advanceChar!|)) (|tokenInstall| val 'number token (size buf)))) ; **** 4. BOOT token parsing actions diff --git a/src/interp/fnewmeta.lisp b/src/interp/fnewmeta.lisp index 658bc9f3..8ea479a7 100644 --- a/src/interp/fnewmeta.lisp +++ b/src/interp/fnewmeta.lisp @@ -174,7 +174,7 @@ (CONS 'CATEGORY (CONS (|popStack2|) (APPEND (|popStack1|) NIL))))) - (AND (ACTION (SETQ G1 (LINE-NUMBER CURRENT-LINE))) + (AND (ACTION (SETQ G1 (|lineNumber| |$spadLine|))) (OR (|PARSE-Application|) (|PARSE-OperatorFunctionName|)) (MUST (OR (AND (MATCH-ADVANCE-STRING ":") @@ -299,10 +299,10 @@ (PROG (G1) (RETURN (AND (EQ (|currentSymbol|) '$) - (OR (ALPHA-CHAR-P (CURRENT-CHAR)) - (CHAR-EQ (CURRENT-CHAR) "$") - (CHAR-EQ (CURRENT-CHAR) "%") - (CHAR-EQ (CURRENT-CHAR) "(")) + (OR (ALPHA-CHAR-P (|currentChar|)) + (CHAR-EQ (|currentChar|) "$") + (CHAR-EQ (|currentChar|) "%") + (CHAR-EQ (|currentChar|) "(")) (ACTION (SETQ G1 (|copyToken| |$priorToken|))) (|PARSE-Qualification|) (ACTION (SETQ |$priorToken| G1)))))) @@ -577,7 +577,7 @@ (DEFUN |PARSE-Selector| () (OR (AND |$nonblank| (EQ (|currentSymbol|) '|.|) - (CHAR-NE (CURRENT-CHAR) '| |) (MATCH-ADVANCE-STRING ".") + (CHAR-NE (|currentChar|) '| |) (MATCH-ADVANCE-STRING ".") (MUST (|PARSE-PrimaryNoFloat|)) (MUST (|pushReduction| '|PARSE-Selector| (CONS (|popStack2|) (CONS (|popStack1|) NIL))))) @@ -621,21 +621,21 @@ (DEFUN |PARSE-FloatBase| () - (OR (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (CURRENT-CHAR) ".") - (CHAR-NE (NEXT-CHAR) ".") (|PARSE-IntegerTok|) + (OR (AND (INTEGERP (|currentSymbol|)) (CHAR-EQ (|currentChar|) ".") + (CHAR-NE (|nextChar|) ".") (|PARSE-IntegerTok|) (MUST (|PARSE-FloatBasePart|))) (AND (INTEGERP (|currentSymbol|)) - (CHAR-EQ (CHAR-UPCASE (CURRENT-CHAR)) 'E) + (CHAR-EQ (CHAR-UPCASE (|currentChar|)) 'E) (|PARSE-IntegerTok|) (|pushReduction| '|PARSE-FloatBase| 0) (|pushReduction| '|PARSE-FloatBase| 0)) - (AND (DIGITP (CURRENT-CHAR)) (EQ (|currentSymbol|) '|.|) + (AND (DIGITP (|currentChar|)) (EQ (|currentSymbol|) '|.|) (|pushReduction| '|PARSE-FloatBase| 0) (|PARSE-FloatBasePart|)))) (DEFUN |PARSE-FloatBasePart| () (AND (MATCH-ADVANCE-STRING ".") - (MUST (OR (AND (DIGITP (CURRENT-CHAR)) + (MUST (OR (AND (DIGITP (|currentChar|)) (|pushReduction| '|PARSE-FloatBasePart| (|tokenNonblank?| (|currentToken|))) (|PARSE-IntegerTok|)) @@ -647,7 +647,7 @@ (PROG (G1) (RETURN (OR (AND (MEMBER (|currentSymbol|) '(E |e|)) - (FIND (CURRENT-CHAR) "+-") (ACTION (|advanceToken|)) + (FIND (|currentChar|) "+-") (ACTION (|advanceToken|)) (MUST (OR (|PARSE-IntegerTok|) (AND (MATCH-ADVANCE-STRING "+") (MUST (|PARSE-IntegerTok|))) diff --git a/src/interp/lexing.boot b/src/interp/lexing.boot index f0378625..a9a161c0 100644 --- a/src/interp/lexing.boot +++ b/src/interp/lexing.boot @@ -35,12 +35,112 @@ --% import sys_-utility +import sys_-macros namespace BOOT module lexing --% +--% Line abstract datatype +--% structure Line == +--% Record(buffer: String, curChar: Character, +--% curIdx: SingleInteger, lstIdx: SingleInteger, lineNo: SingleInteger) +--% +makeLine(buf == makeString 0, ch == charByName "Return", + curIdx == 1, lstIdx == 0, no == 0) == + [buf,ch,curIdx,lstIdx,no] + +macro lineBuffer l == + first l + +macro lineCurrentChar l == + second l + +macro lineCurrentIndex l == + third l + +macro lineLastIndex l == + fourth l + +macro lineNumber l == + fifth l + +lineClear! l == + lineBuffer(l) := makeString 0 + lineCurrentChar(l) := charByName "Return" + lineCurrentIndex(l) := 1 + lineLastIndex(l) := 0 + lineNumber(l) := 0 + +++ Sets string to be the next line stored in line +lineNewLine!(s,l,no == nil) == + sz := #s + lineLastIndex(l) := sz - 1 + lineCurrentIndex(l) := 0 + lineCurrentChar(l) := sz > 0 and s.0 or charByName '"Return" + lineBuffer(l) := s + lineNumber(l) := no or (lineNumber l + 1) + +++ Tests if line is empty or positioned past the last character +lineAtEnd? l == + lineCurrentIndex l >= lineLastIndex l + +++ Tests if line is empty or positioned past the last character +linePastEnd? l == + lineCurrentIndex l > lineLastIndex l + +++ Buffer from current index to last index +lineCurrentSegment l == + lineAtEnd? l => makeString 0 + subSequence(lineBuffer l,lineCurrentIndex l,lineLastIndex l) + +lineNextChar l == + lineBuffer(l).(1 + lineCurrentIndex l) + +lineAdvanceChar! l == + n := lineCurrentIndex l + 1 + lineCurrentIndex(l) := n + lineCurrentChar(l) := lineBuffer(l).n + +++ Current input line +$spadLine := makeLine() + +++ List of lines returned from PREPARSE +$lineStack := nil + +nextLine st == + $lineStack = nil => nil + [[n,:l],:$lineStack] := $lineStack + l := strconc(l,'" ") + lineNewLine!(l,$spadLine,n) + SETQ(LINE,l) + $currentLine := l + +++ Current input stream. +IN_-STREAM := 'T + +++ Advances IN-STREAM, invoking Next Line if necessary +advanceChar!() == + repeat + not lineAtEnd? $spadLine => return lineAdvanceChar! $spadLine + nextLine IN_-STREAM => return currentChar() + return nil + +--% + +++ Returns the current character of the line, initially blank for +++ an unread line +currentChar() == + linePastEnd? $spadLine => charByName "Return" + lineCurrentChar $spadLine + +nextChar() == + lineAtEnd? $spadLine => charByName '"Return" + lineNextChar $spadLine + + +--% --% Token abstract datatype. --% Operational semantics: --% structure Token == @@ -138,6 +238,67 @@ makeSymbolOf tok == currentSymbol() == makeSymbolOf currentToken() +tokenStackClear!() == + $validTokens := 0 + tokenInstall(nil,nil,$currentToken,nil) + tokenInstall(nil,nil,$nextToken,nil) + tokenInstall(nil,nil,$priorToken,nil) + +--% +Keywords == [ + "or", "and", "isnt", "is", "when", "where", "forall", "exist", "try", + "has", "with", "add", "case", "in", "by", "pretend", "mod", "finally", + "exquo", "div", "quo", "else", "rem", "then", "suchthat", "catch", "throw", + "if", "iterate", "break", "from", "exit", "leave", "return", + "not", "repeat", "until", "while", "for", "import", "inline" ] + +escapeKeywords(nm,id) == + symbolMember?(id,Keywords) => strconc('"__",nm) + nm + +underscore s == + n := #s - 1 + and/[alphabetic? stringChar(s,i) for i in 0..n] => s + buf := nil + for i in 0..n repeat + c := stringChar(s,i) + if not alphabetic? c then + buf := [char "__",:buf] + buf := [c,:buf] + listToString reverse! buf + +quoteIfString tok == + tok = nil => nil + tt := tokenType tok + tt is 'SPADSTRING => strconc('"_"",underscore tokenSymbol tok,'"_"") + tt is 'NUMBER => formatToString('"~v,'0D",tokenNonblank? tok,tokenSymbol tok) + tt is 'SPECIAL_-CHAR => charString tokenSymbol tok + tt is 'IDENTIFIER => + escapeKeywords(symbolName tokenSymbol tok,tokenSymbol tok) + tokenSymbol tok + +ungetTokens() == + $validTokens = 0 => true + $validTokens = 1 => + cursym := quoteIfString $currentToken + curline := lineCurrentSegment $spadLine + revisedline := strconc(cursym,curline,'" ") + lineNewLine!(revisedline,$spadLine,lineNumber $spadLine) + $nonblank := tokenNonblank? $currentToken + $validTokens := 0 + $validTokens = 2 => + cursym := quoteIfString $currentToken + nextsym := quoteIfString $nextToken + curline := lineCurrentSegment $spadLine + revisedline := strconc((tokenNonblank? $currentToken => '""; '" "), + cursym,(tokenNonblank? $nextToken => '""; '" "),nextsym,curline,'" ") + $nonblank := tokenNonblank? $currentToken + lineNewLine!(revisedline,$spadLine,lineNumber $spadLine) + $validTokens := 0 + coreError '"How many tokens do you think you have?" + + + --% --% Stack abstract datatype. --% Operational semantics: diff --git a/src/interp/metalex.lisp b/src/interp/metalex.lisp index aeb493d1..40dc84c2 100644 --- a/src/interp/metalex.lisp +++ b/src/interp/metalex.lisp @@ -47,7 +47,6 @@ ; 0. Current I/O Stream definition -(defparameter in-stream t "Current input stream.") (defparameter out-stream t "Current output stream.") (defparameter File-Closed nil "Way to stop EOF tests for console input.") @@ -70,58 +69,12 @@ ; FUNCTIONS DEFINED IN THIS SECTION: ; -; Line-Buffer, Line-Current-Char, Line-Current-Index, Line-Last-Index, Line-Number ; Line-New-Line, Line-Advance-Char, Line-Past-End-P, Line-At-End-P ; Make-Line -(defstruct Line "Line of input file to parse." - (Buffer (make-string 0) :type string) - (Current-Char #\Return :type character) - (Current-Index 1 :type fixnum) - (Last-Index 0 :type fixnum) - (Number 0 :type fixnum)) - (defun Line-Print (line) - (format out-stream "~&~5D> ~A~%" (Line-Number line) (Line-Buffer Line)) - (format out-stream "~v@T^~%" (+ 7 (Line-Current-Index line)))) - -(defmacro Line-Clear (line) - `(let ((l ,line)) - (setf (Line-Buffer l) (make-string 0) - (Line-Current-Char l) #\Return - (Line-Current-Index l) 1 - (Line-Last-Index l) 0 - (Line-Number l) 0))) - -(defun Line-Current-Segment (line) - "Buffer from current index to last index." - (if (line-at-end-p line) (make-string 0) - (subseq (Line-Buffer line) - (Line-Current-Index line) - (Line-Last-Index line)))) - -(defun Line-New-Line (string line &optional (linenum nil)) - "Sets string to be the next line stored in line." - (setf (Line-Last-Index line) (1- (length string)) - (Line-Current-Index line) 0 - (Line-Current-Char line) (or (and (> (length string) 0) (elt string 0)) #\Return) - (Line-Buffer line) string - (Line-Number line) (or linenum (1+ (Line-Number line))))) - -(defun Line-Advance-Char (line) - (setf (Line-Current-Char line) - (elt (Line-Buffer line) (incf (Line-Current-Index line))))) - -(defun Line-Next-Char (line) - (elt (Line-Buffer line) (1+ (Line-Current-Index line)))) - -(defun Line-Past-End-P (line) - "Tests if line is empty or positioned past the last character." - (> (line-current-index line) (line-last-index line))) - -(defun Line-At-End-P (line) - "Tests if line is empty or positioned past the last character." - (>= (line-current-index line) (line-last-index line))) + (format out-stream "~&~5D> ~A~%" (|lineNumber| line) (|lineBuffer| Line)) + (format out-stream "~v@T^~%" (+ 7 (|lineCurrentIndex| line)))) ; *** Next Line @@ -142,16 +95,13 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (defun input-clear () (setq Current-Fragment nil)) - -(defparameter Boot-Line-Stack nil "List of lines returned from PREPARSE.") - -(defun Next-Lines-Clear () (setq Boot-Line-Stack nil)) +(defun Next-Lines-Clear () (setq |$lineStack| nil)) (defun Next-Lines-Show () - (and Boot-Line-Stack (format t "Currently preparsed lines are:~%~%")) + (and |$lineStack| (format t "Currently preparsed lines are:~%~%")) (mapcar #'(lambda (line) (format t "~&~5D> ~A~%" (car line) (cdr Line))) - Boot-Line-Stack)) + |$lineStack|)) ; 3. Routines for handling lexical scanning @@ -159,20 +109,18 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") ; Lexical scanning of tokens is performed off of the current line. No ; token can span more than 1 line. All real I/O is handled in a line-oriented ; fashion (in a slight paradox) below the character level. All character -; routines implicitly assume the parameter Current-Line. We do not make -; Current-Line an explicit optional parameter for reasons of efficiency. - -(defparameter Current-Line (make-line) "Current input line.") +; routines implicitly assume the parameter |$spadLine|. We do not make +; |$spadLine| an explicit optional parameter for reasons of efficiency. -(defmacro current-line-print () '(Line-Print Current-Line)) +(defmacro current-line-print () '(Line-Print |$spadLine|)) (defmacro current-line-show () - `(if (line-past-end-p current-line) + `(if (|linePastEnd?| |$spadLine|) (format t "~&The current line is empty.~%") (progn (format t "~&The current line is:~%~%") (current-line-print)))) -(defmacro current-line-clear () `(Line-Clear Current-Line)) +(defmacro current-line-clear () `(|lineClear!| |$spadLine|)) (defun read-a-line (&optional (stream t)) (let (cp) @@ -185,7 +133,7 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (prog nil (if (stream-eof in-stream) (progn (setq File-Closed t *EOF* t) - (Line-New-Line (make-string 0) Current-Line) + (|lineNewLine!| (make-string 0) |$spadLine|) (return nil))) (if (setq Current-Fragment (read-line stream)) (return (read-a-line stream))))))) @@ -206,34 +154,6 @@ Symbolics read-line returns embedded newlines in a c-m-Y.") (|stackClear!| Printer-Line-Stack) (format strm "~&; ~A~%" string)))) - -; 3A (2) Character handling. - -; FUNCTIONS DEFINED IN THIS SECTION: -; -; Current-Char, Next-Char, Advance-Char - -; *** Current Char, Next Char, Advance Char - -(defun Current-Char () - "Returns the current character of the line, initially blank for an unread line." - (if (Line-Past-End-P Current-Line) #\Return (Line-Current-Char Current-Line))) - -(defun Next-Char () - "Returns the character after the current character, blank if at end of line. -The blank-at-end-of-line assumption is allowable because we assume that end-of-line -is a token separator, which blank is equivalent to." - - (if (Line-At-End-P Current-Line) #\Return (Line-Next-Char Current-Line))) - -(defun Advance-Char () - "Advances IN-STREAM, invoking Next Line if necessary." - (loop (cond ((not (Line-At-End-P Current-Line)) - (return (Line-Advance-Char Current-Line))) - ((next-boot-line in-stream) - (return (current-char))) - ((return nil))))) - ; 1C. Token (defun Token-Print (token) (format out-stream "(token (symbol ~S) (type ~S))~%" @@ -252,36 +172,6 @@ is a token separator, which blank is equivalent to." (format t "~%There is nothing on the reduction stack.~%")))) -; *** 2. META Line Handling -(defparameter Comment-Character #\% "Delimiter of comments in Meta code.") - -(defun kill-comments (string) - "Deletes from comment character % to end of STRING." - (subseq string 0 - (let ((mi (maxindex string))) - (do ((i 0 (1+ i))) - ((> i mi) i) - (if (and (char= (elt string i) Comment-Character) - (or (eq i 0) (char/= (elt string (1- i)) #\\))) - (return i)))))) - -(defun kill-trailing-blanks (string) - - "Remove white space from end of STRING." - - ; Coding note: yes, I know, use string-trim -- but it is broken - ; in Symbolics Common Lisp for short strings - - (let* ((sl (length string)) - (right (if (= sl 0) -1 - (or - (position-if-not - #'(lambda (x) - (member x '(#\Space #\Tab #\Newline) :test #'char=)) - string :from-end t) - -1)))) - (if (>= right 0) (subseq string 0 (1+ right)) (make-string 0)))) - ; *** 3. META Token Handling ; STRING: "'" { Chars - "'" }* "'" @@ -322,90 +212,6 @@ is a token separator, which blank is equivalent to." (progn (format t "The prior token was~%") (describe |$priorToken|)))) -(defmacro token-stack-clear () - `(progn (setq |$validTokens| 0) - (|tokenInstall| nil nil |$currentToken| nil) - (|tokenInstall| nil nil |$nextToken| nil) - (|tokenInstall| nil nil |$priorToken| nil))) - -; Unget-Tokens - -(defun quote-if-string (token) - (if token ;only use |tokenType| on non-null tokens - (case (|tokenType| token) - (bstring (strconc "[" (|tokenSymbol| token) "]*")) - (string (strconc "'" (|tokenSymbol| token) "'")) - (spadstring (strconc "\"" (underscore (|tokenSymbol| token)) "\"")) - (number (format nil "~v,'0D" (|tokenNonblank?| token) - (|tokenSymbol| token))) - (special-char (string (|tokenSymbol| token))) - (identifier (let ((id (symbol-name (|tokenSymbol| token))) - (pack (package-name (symbol-package - (|tokenSymbol| token))))) - (if $SPAD - (if (equal pack "BOOT") - (escape-keywords (underscore id) (|tokenSymbol| token)) - (concatenate 'string - (underscore pack) "'" (underscore id))) - id))) - (t (|tokenSymbol| token))) - nil)) - - -(defconstant Keywords - '(|or| |and| |isnt| |is| |when| |where| |forall| |exist| |try| - |has| |with| |add| |case| |in| |by| |pretend| |mod| |finally| - |exquo| |div| |quo| |else| |rem| |then| |suchthat| |catch| |throw| - |if| |yield| |iterate| |break| |from| |exit| |leave| |return| - |not| |unless| |repeat| |until| |while| |for| |import| |inline|) - -"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 escape-keywords (pname id) - (if (member id keywords) - (concatenate 'string "_" pname) - pname)) - -(defun underscore (string) - (if (every #'alpha-char-p string) string - (let* ((size (length string)) - (out-string (make-array (* 2 size) - :element-type 'character - :fill-pointer 0)) - next-char) - (dotimes (i size) - (setq next-char (char string i)) - (if (not (alpha-char-p next-char)) - (vector-push #\_ out-string)) - (vector-push next-char out-string)) - out-string))) - -(defun Unget-Tokens () - (case |$validTokens| - (0 t) - (1 (let* ((cursym (quote-if-string |$currentToken|)) - (curline (line-current-segment current-line)) - (revised-line (strconc cursym curline (copy-seq " ")))) - (line-new-line revised-line current-line (line-number current-line)) - (setq |$nonblank| (|tokenNonblank?| |$currentToken|)) - (setq |$validTokens| 0))) - (2 (let* ((cursym (quote-if-string |$currentToken|)) - (nextsym (quote-if-string |$nextToken|)) - (curline (line-current-segment current-line)) - (revised-line - (strconc (if (|tokenNonblank?| |$currentToken|) "" " ") - cursym - (if (|tokenNonblank?| |$nextToken|) "" " ") - nextsym curline " "))) - (setq |$nonblank| (|tokenNonblank?| |$currentToken|)) - (line-new-line revised-line current-line (line-number current-line)) - (setq |$validTokens| 0))) - (t (error "How many tokens do you think you have?")))) (defun-parse-token STRING) (defun-parse-token BSTRING) @@ -425,131 +231,27 @@ as keywords.") (when (and id (member id |$OperatorFunctionNames|)) (|pushReduction| '|PARSE-OperatorFunctionName| id) (action (|advanceToken|))))) - -; Meta tokens fall into the following categories: -; -; Number -; Identifier -; Dollar-sign -; Special character -; -; Special characters are represented as characters, numbers as numbers, and -; identifiers as strings. The reason identifiers are represented as strings is -; that the full print-name of the intern of a string depends on the package you -; are currently executing in; this can lead to very confusing results! - -(defun get-META-token (token) - (prog nil - loop (if (not (skip-blanks)) (return nil)) - (case (token-lookahead-type (current-char)) - (id (return (get-identifier-token token))) - (num (return (get-number-token token))) - (string (return (get-string-token token))) - (bstring (return (get-bstring-token token))) -; (dollar (return (get-identifier-token token))) - (special-char (return (get-special-token token))) - (eof (return nil))))) - -(defun skip-blanks () - (loop (let ((cc (current-char))) - (if (not cc) (return nil)) - (if (eq (token-lookahead-type cc) 'white) - (if (not (advance-char)) (return nil)) - (return t))))) - -(defparameter Escape-Character #\\ "Superquoting character.") - -(defun token-lookahead-type (char) - "Predicts the kind of token to follow, based on the given initial character." - (cond ((not char) 'eof) - ((or (char= char Escape-Character) (alpha-char-p char)) 'id) - ((digitp char) 'num) - ((char= char #\') 'string) - ((char= char #\[) 'bstring) -; ((char= char #\$) (advance-char) 'dollar) - ((member char '(#\Space #\Tab #\Return) :test #'char=) 'white) - (t 'special-char))) (defun make-adjustable-string (n) (make-array (list n) :element-type 'character :adjustable t)) - -(defun get-identifier-token (token) - "Take an identifier off the input stream." - (prog ((buf (make-adjustable-string 0))) - id (let ((cur-char (current-char))) - (cond ((equal cur-char Escape-Character) - (if (not (advance-char)) (go bye)) - (suffix (current-char) buf) - (if (not (advance-char)) (go bye)) - (go id)) - ((or (alpha-char-p cur-char) - (char= cur-char #\-) - (digitp cur-char) - (char= cur-char #\_)) - (suffix (current-char) buf) - (if (not (advance-char)) (go bye)) - (go id)))) - bye (return (|tokenInstall| (intern buf) 'identifier token)))) - -(defun get-string-token (token) - "With 'ABC' on IN-STREAM, extracts and stacks String 'ABC'." - (let ((buf (make-adjustable-string 0))) - (if (char= (current-char) #\') - (progn (advance-char) - (loop (case (current-char) - (#\' (advance-char) - (return (|tokenInstall| buf 'string token))) - (#\\ (advance-char) - (suffix (current-char) buf) - (advance-char)) - (#\Return - (moan "String should fit on one line!") - (advance-char) - (spad_syntax_error) - (return nil)) - (t (suffix (current-char) buf) - (advance-char)))))))) - -(defun get-bstring-token (token) - "With ABC]* on in-stream, extracts and stacks string ABC." - (let ((buf (make-adjustable-string 0))) - (if (char= (current-char) #\[) - (progn (advance-char) - (loop (case (current-char) - (#\] (if (char= (next-char) #\*) - (progn (advance-char) - (advance-char) - (return (|tokenInstall| buf 'bstring token))) - (progn (suffix (current-char) buf) - (advance-char)))) - (#\\ (advance-char) - (suffix (current-char) buf) - (advance-char)) - (#\Return - (moan "String should fit on one line!") - (advance-char) - (spad_syntax_error) - (return nil)) - (t (suffix (current-char) buf) - (advance-char)))))))) (defun get-special-token (token) "Take a special character off the input stream. We let the type name of each special character be the atom whose print name is the character itself." - (let ((symbol (current-char))) - (advance-char) + (let ((symbol (|currentChar|))) + (|advanceChar!|) (|tokenInstall| symbol 'special-char token))) (defun get-number-token (token) "Take a number off the input stream." (prog ((buf (make-adjustable-string 0))) nu1 - (suffix (current-char) buf) ; Integer part - (let ((next-chr (next-char))) + (suffix (|currentChar|) buf) ; Integer part + (let ((next-chr (|nextChar|))) (cond ((digitp next-chr) - (advance-char) + (|advanceChar!|) (go nu1)))) - (advance-char) + (|advanceChar!|) (return (|tokenInstall| (read-from-string buf) 'number token (size buf) ;used to keep track of digit count diff --git a/src/interp/parsing.lisp b/src/interp/parsing.lisp index 9aaf86ed..28a02239 100644 --- a/src/interp/parsing.lisp +++ b/src/interp/parsing.lisp @@ -178,24 +178,24 @@ the stack, then stack a NIL. Return the value of prod." (defun Match-String (x) "Returns length of X if X matches initial segment of inputstream." - (unget-tokens) ; So we don't get out of synch with token stream - (skip-blanks) - (if (and (not (Line-Past-End-P Current-Line)) (Current-Char) ) + (|ungetTokens|) ; So we don't get out of synch with token stream + (boot-skip-blanks) + (if (and (not (|linePastEnd?| |$spadLine|)) (|currentChar|) ) (initial-substring-p x - (subseq (Line-Buffer Current-Line) (Line-Current-Index Current-Line))))) + (subseq (|lineBuffer| |$spadLine|) (|lineCurrentIndex| |$spadLine|))))) (defun Match-Advance-String (x) "Same as MATCH-STRING except if successful, advance inputstream past X." (let ((y (if (>= (length (string x)) - (length (string (quote-if-string (|currentToken|))))) + (length (string (|quoteIfString| (|currentToken|))))) (Match-String x) nil))) ; must match at least the current token - (if y (progn (incf (Line-Current-Index Current-Line) y) - (if (not (Line-Past-End-P Current-Line)) - (setf (Line-Current-Char Current-Line) - (elt (Line-Buffer Current-Line) - (Line-Current-Index Current-Line))) - (setf (Line-Current-Char Current-Line) #\Space)) + (if y (progn (incf (|lineCurrentIndex| |$spadLine|) y) + (if (not (|linePastEnd?| |$spadLine|)) + (setf (|lineCurrentChar| |$spadLine|) + (elt (|lineBuffer| |$spadLine|) + (|lineCurrentIndex| |$spadLine|))) + (setf (|lineCurrentChar| |$spadLine|) #\Space)) (setq |$priorToken| (|makeToken| (intern (string x)) 'identifier |$nonblank|)) t)))) @@ -236,7 +236,7 @@ the stack, then stack a NIL. Return the value of prod." (defun conversation1 (firstfun procfun) (prog nil - top(cond ((not (Current-Char)) (return nil)) + top(cond ((not (|currentChar|)) (return nil)) ((and (|currentToken|) (|nextToken|)) (go top)) ((compfin) (return 't)) ((and (funcall firstfun) @@ -247,7 +247,7 @@ the stack, then stack a NIL. Return the value of prod." (go top))) (defun termchr () "Is CHR a terminating character?" - (position (current-char) " *,;<>()[]/\\")) + (position (|currentChar|) " *,;<>()[]/\\")) (defun compfin () (or (match-string ")fin") (match-string ".FIN"))) @@ -414,9 +414,9 @@ the stack, then stack a NIL. Return the value of prod." (trblanks (* 2 /depth)) (setq /depth (+ 1 /depth)) (princ (stringimage /depth)) (princ "<") (princ nam*) (trargprint argl*) (princ "/") - (princ "chr= ") (prin1 (Current-Char)) + (princ "chr= ") (prin1 (|currentChar|)) (princ "/tok= ") (prin1 (setq tok (current-symbol))) - (princ "/col= ") (prin1 (line-current-index current-line)) + (princ "/col= ") (prin1 (|lineCurrentIndex| |$spadLine|)) ;; (princ "/icol= ") (prin1 initcolumn) (cond ( (not nonblank) (go a1))) (princ "/nblnk= T") a1 ;;(cond (ok (go b1))) (princ "/ok= NIL") @@ -430,9 +430,9 @@ the stack, then stack a NIL. Return the value of prod." (terpri) (trblanks (* 2 /depth)) (princ (stringimage (\1+ /depth))) (princ ">") (princ nam*) - (princ "/chr= ") (prin1 (Current-Char)) + (princ "/chr= ") (prin1 (|currentChar|)) (princ "/tok= ") (prin1 (setq tok (current-symbol))) - (princ "/col= ") (prin1 (line-current-index current-line)) + (princ "/col= ") (prin1 (|lineCurrentIndex| |$spadLine|)) (if (not nonblank) (go a2)) (princ "/nblnk= ") (princ (if nonblank "T" "NIL")) a2 ;;(if ok (go b2)) (princ "/ok= ") (prin1 ok) @@ -504,7 +504,7 @@ the stack, then stack a NIL. Return the value of prod." ;(IOStreams-clear in out) (input-clear) (current-line-clear) - (token-stack-clear) + (|tokenStackClear!|) (|reduceStackClear|) (if $SPAD (next-lines-clear)) nil) diff --git a/src/interp/spad.lisp b/src/interp/spad.lisp index d08d692b..2b883cae 100644 --- a/src/interp/spad.lisp +++ b/src/interp/spad.lisp @@ -158,9 +158,9 @@ (defun READLISP (UPPER_CASE_FG) (let (v expr val ) (setq EXPR (READ-FROM-STRING - (IF UPPER_CASE_FG (string-upcase (line-buffer CURRENT-LINE)) - (line-buffer CURRENT-LINE)) - t nil :start (Line-CURRENT-INDEX CURRENT-LINE))) + (IF UPPER_CASE_FG (string-upcase (line-buffer |$spadLine|)) + (line-buffer |$spadLine|)) + t nil :start (Line-CURRENT-INDEX |$spadLine|))) (VMPRINT EXPR) (setq VAL ((LAMBDA (|$InteractiveMode|) (EVAL EXPR)) NIL)) (FORMAT t "~&VALUE = ~S" VAL) |