aboutsummaryrefslogtreecommitdiff
path: root/src/interp
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp')
-rw-r--r--src/interp/Makefile.in2
-rw-r--r--src/interp/bootlex.lisp101
-rw-r--r--src/interp/fnewmeta.lisp24
-rw-r--r--src/interp/lexing.boot161
-rw-r--r--src/interp/metalex.lisp332
-rw-r--r--src/interp/parsing.lisp36
-rw-r--r--src/interp/spad.lisp6
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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-26 00:47:47 +0000