;; SAL parser -- replaces original pattern-directed parser with

;; a recursive descent one

;;

;; Parse functions either parse correctly and return

;; compiled code as a lisp expression (which could be nil)

;; or else they call parse-error, which does not return

;; (instead, parse-error forces a return from parse)

;; In the original SAL parser, triples were returned

;; including the remainder if any of the tokens to be

;; parsed. In this parser, tokens are on the list

;; *sal-tokens*, and whatever remains on the list is

;; the list of unparsed tokens.

;; scanning delimiters.

(setfn nreverse reverse)

(defconstant +quote+ #\") ; "..." string

(defconstant +kwote+ #\') ; '...' kwoted expr

(defconstant +comma+ #\,) ; positional arg delimiter

(defconstant +pound+ #\#) ; for bools etc

(defconstant +semic+ #\;) ; comment char

(defconstant +lbrace+ #\{) ; {} list notation

(defconstant +rbrace+ #\})

(defconstant +lbrack+ #\[) ; unused for now

(defconstant +rbrack+ #\])

(defconstant +lparen+ #\() ; () expr and arg grouping

(defconstant +rparen+ #\))

;; these are defined so that SAL programs can name these symbols

;; note that quote(>) doesn't work, so you need quote(symbol:greater)

(setf symbol:greater '>)

(setf symbol:less '<)

(setf symbol:greater-equal '>=)

(setf symbol:less-equal '<=)

(setf symbol:equal '=)

(setf symbol:not '!)

(setf symbol:not-equal '/=)

(defparameter +whites+ (list #\space #\tab #\newline (code-char 13)))

(defparameter +kwstyle+ (list :suffix #\:)) ; let's try dylan

(defparameter +operators+

;; each op is: (<token-class> <sal-name> <lisp-form>)

'((:+ "+" sum)

(:- "-" diff)

(:* "*" mult)

(:/ "/" /)

(:% "%" rem)

(:^ "^" expt)

(:= "=" sal-equal) ; equality and assigment

(:!= "!=" not-sal-equal)

(:< "<" <)

(:> ">" >)

(:<= "<=" <=) ; leq and assignment minimization

(:>= ">=" >=) ; geq and assignment maximization

(:~= "~=" equal) ; general equality

(:+= "+=" +=) ; assignment increment-and-store

(:-= "-=" -=) ; assignment increment-and-store

(:*= "*=" *=) ; assignment multiply-and-store

(:/= "/=" /=) ; assignment multiply-and-store

(:&= "&=" &=) ; assigment list collecting

(:@= "@=" @=) ; assigment list prepending

(:^= "^=" ^=) ; assigment list appending

(:! "!" not)

(:& "&" and)

(:\| "|" or)

(:~ "~" sal-stretch)

(:~~ "~~" sal-stretch-abs)

(:@ "@" sal-at)

(:@@ "@@" sal-at-abs)

))

(setf *sal-local-variables* nil) ;; used to avoid warning about variable

;; names when the variable has been declared as a local

(defparameter *sal-operators*

'(:+ :- :* :/ :% :^ := :!= :< :> :<= :>= :~= :+= :*= :&= :@= :^= :! :& :\|

:~ :~~ :@ :@@))

(defparameter +delimiters+

'((:lp #\()

(:rp #\))

(:lc #\{) ; left curly

(:rc #\})

(:lb #\[)

(:rb #\])

(:co #\,)

(:kw #\') ; kwote

(nil #\") ; not token

; (nil #\#)

(nil #\;)

))

(setf *reserved-words* '((::+ ":+") (::- ":-") (::* ":*") (::/ ":/") (::= ":=")

(::!= ":!=") (::< ":<") (::> ":>") (::<= ":<=")

(::>= ":>=") (::~= ":~=") (::! ":!") (::& ":&")

(::\| ":|") (:IF "if") (:THEN "then") (:ELSE "else")

(:WHEN "when") (:UNLESS "unless") (:SET "set")

(:= "=") (:+= "+=") (:*= "*=") (:&= "&=") (:@= "@=")

(:^= "^=") (:<= "<=") (:>= ">=") (:PRINT "print")

(:LOOP "loop")

(:RUN "run") (:REPEAT "repeat") (:FOR "for")

(:FROM "from") (:IN "in") (:BELOW "below") (:TO "to")

(:ABOVE "above") (:DOWNTO "downto") (:BY "by")

(:OVER "over") (:WHILE "while") (:UNTIL "until")

(:FINALLY "finally") (:RETURN "return")

(:WAIT "wait") (:BEGIN "begin") (:WITH "with")

(:END "end") (:VARIABLE "variable")

(:FUNCTION "function") (:PROCESS "process")

(:CHDIR "chdir") (:DEFINE "define") (:LOAD "load")

(:PLAY "play")

(:EXEC "exec") (:exit "exit") (:DISPLAY "display")

(:~ "~") (:~~ "~~") (:@ ":@") (:@@ ":@@")))

(setf *sal-fn-name* nil)

(defun make-sal-error (&key type text (line nil) start)

; (error 'make-sal-error-was-called-break)

(list 'sal-error type text line start))

(setfn sal-error-type cadr)

(setfn sal-error-text caddr)

(setfn sal-error-line cadddr)

(defun sal-error-start (x) (cadddr (cdr x)))

(defun is-sal-error (x) (and x (eq (car x) 'sal-error)))

(defun sal-tokens-error-start (start)

(cond (start

start)

(*sal-tokens*

(token-start (car *sal-tokens*)))

(t

(length *sal-input-text*))))

(defmacro errexit (message &optional start)

`(parse-error (make-sal-error :type "parse"

:line *sal-input-text* :text ,message

:start ,(sal-tokens-error-start start))))

(defmacro sal-warning (message &optional start)

`(pperror (make-sal-error :type "parse" :line *sal-input-text*

:text ,message

:start ,(sal-tokens-error-start start))

"warning"))

(setf *pos-to-line-source* nil)

(setf *pos-to-line-pos* nil)

(setf *pos-to-line-line* nil)

(defun pos-to-line (pos source)

;; this is really inefficient to search every line from

;; the beginning, so cache results and search forward

;; from there if possible

(let ((i 0) (line-no 1)) ;; assume no cache

;; see if we can use the cache

(cond ((and (eq source *pos-to-line-source*)

*pos-to-line-pos* *pos-to-line-line*

(>= pos *pos-to-line-pos*))

(setf i *pos-to-line-pos*)

(setf line-no *pos-to-line-line*)))

;; count newlines up to pos

(while (< i pos)

(if (char= (char source i) #\newline)

(incf line-no))

(setf i (1+ i)))

;; save results in cache

(setf *pos-to-line-source* source

*pos-to-line-pos* pos

*pos-to-line-line* line-no)

;; return the line number at pos in source

line-no))

;; makes a string of n spaces, empty string if n <= 0

(defun make-spaces (n)

(cond ((> n 16)

(let* ((half (/ n 2))

(s (make-spaces half)))

(strcat s s (make-spaces (- n half half)))))

(t

(subseq " " 0 (max n 0)))))

(defun pperror (x &optional (msg-type "error"))

(let* ((source (sal-error-line x))

(llen (length source))

line-no

beg end)

; (display "pperror" x (strcat "|" (sal-error-line x) "|"))

;; isolate line containing error

(setf beg (sal-error-start x))

(setf beg (min beg (1- llen)))

(do ((i beg (- i 1))

(n nil)) ; n gets set when we find a newline

((or (< i 0) n)

(setq beg (or n 0)))

(if (char= (char source i) #\newline)

(setq n (+ i 1))))

(do ((i (sal-error-start x) (+ i 1))

(n nil))

((or (>= i llen) n)

(setq end (or n llen)))

(if (char= (char source i) #\newline)

(setq n i)))

(setf line-no (pos-to-line beg source))

; (display "pperror" beg end (sal-error-start x))

;; print the error. include the specfic line of input containing

;; the error as well as a line below it marking the error position

;; with an arrow: ^

(let* ((pos (- (sal-error-start x) beg))

(line (if (and (= beg 0) (= end llen))

source

(subseq source beg end)))

(mark (make-spaces pos)))

(format t "~%>>> ~A ~A: ~A.~%>>> in ~A, line ~A, col ~A.~%~%~A~%~A^~%"

(sal-error-type x) msg-type (sal-error-text x)

*sal-input-file-name* line-no (1+ pos)

line mark)

; (format t "~%>>> ~A error in \"~A\", line ~A, col ~A: ~A.~%~%~A~%~A^~%"

; (sal-error-type x) *sal-input-file-name* line-no pos

; (sal-error-text x) line mark)

x)))

;;;

;;; the lexer. right now it assumes input string is complete and ready

;;; to be processed as a valid expression.

;;;

(defun advance-white (str white start end)

;; skip "white" chars, where white can be a char, list of chars

;; or predicate test

(do ((i start )

(p nil))

((or p (if (< start end)

(not (< -1 i end))

(not (> i end -1))))

(or p end))

(cond ((consp white)

(unless (member (char str i) white :test #'char=)

(setq p i)))

((characterp white)

(unless (char= (char str i) white)

(setq p i)))

((functionp white)

(unless (funcall white (char str i))

(setq p i))))

(if (< start end)

(incf i)

(decf i))))

(defun search-delim (str delim start end)

;; find position of "delim" chars, where delim can be

;; a char, list of chars or predicate test

(do ((i start (+ i 1))

(p nil))

((or (not (< i end)) p)

(or p end))

(cond ((consp delim)

(if (member (char str i) delim :test #'char=)

(setq p i)))

((characterp delim)

(if (char= (char str i) delim)

(setq p i)))

((functionp delim)

(if (funcall delim (char str i))

(setq p i))))))

;; UNBALANCED-INPUT AND TOKENIZE HAVE BEEN REWRITTEN, SEE BELOW. THIS ONE IS

;; OLD AND JUST KEPT HERE FOR REFERENCE

#|

(defun unbalanced-input (errf line toks par bra brk kwo)

;; search input for the starting position of some unbalanced

;; delimiter, toks is reversed list of tokens with something

;; unbalanced

(let (char text targ othr levl pos)

(cond ((> par 0) (setq char #\( targ ':lp othr ':rp levl par))

((< par 0) (setq char #\) targ ':rp othr ':lp levl 0))

((> bra 0) (setq char #\{ targ ':lc othr ':rc levl bra))

((< bra 0) (setq char #\} targ ':rc othr ':lc levl 0))

((> brk 0) (setq char #\[ targ ':ls othr ':rs levl brk))

((< brk 0) (setq char #\] targ ':rs othr ':ls levl 0))

((> kwo 0) (setq char #\' targ ':kw othr ':kw levl kwo)))

(setq text (format nil "Unmatched '~A'" char))

;; search for start of error in token list

(do ((n levl)

(tail toks (cdr tail)))

((or (null tail) pos)

(or pos (error (format nil "Shouldn't! can't find op ~A in ~A."

targ (reverse toks)))))

(if (eql (token-type (car tail)) targ)

(if (= n levl)

(setq pos (token-start (car tail)))

(decf n))

(if (eql (token-type (car tail)) othr)

(incf n))))

(errexit text pos)))

(defun tokenize (str reserved error-fn)

;&key (start 0) (end (length str))

; (white-space +whites+) (delimiters +delimiters+)

; (operators +operators+) (null-ok t)

; (keyword-style +kwstyle+) (reserved nil)

; (error-fn nil)

; &allow-other-keys)

;; return zero or more tokens or a sal-error

(let ((toks (list t))

(start 0)

(end (length str))

(all-delimiters +whites+)

(errf (or error-fn

(lambda (x) (pperror x) (return-from tokenize x)))))

(dolist (x +delimiters+)

(push (cadr x) all-delimiters))

(do ((beg start)

(pos nil)

(all all-delimiters)

(par 0)

(bra 0)

(brk 0)

(kwo 0)

(tok nil)

(tail toks))

((not (< beg end))

;; since input is complete check parens levels.

(if (= 0 par bra brk kwo)

(if (null (cdr toks))

(list)

(cdr toks))

(unbalanced-input errf str (reverse (cdr toks))

par bra brk kwo)))

(setq beg (advance-white str +whites+ beg end))

(setf tok

(read-delimited str :start beg :end end

:white +whites+ :delimit all

:skip-initial-white nil :errorf errf))

;; multiple values are returned, so split them here:

(setf pos (second tok)) ; pos is the end of the token (!)

(setf tok (first tok))

;; tok now string, char (delimiter), :eof or token since input

;; is complete keep track of balancing delims

(cond ((eql tok +lbrace+) (incf bra))

((eql tok +rbrace+) (decf bra))

((eql tok +lparen+) (incf par))

((eql tok +rparen+) (decf par))

((eql tok +lbrack+) (incf brk))

((eql tok +rbrack+) (decf brk))

((eql tok +kwote+) (setq kwo (mod (+ kwo 1) 2))))

(cond ((eql tok ':eof)

(setq beg end))

(t

;; may have to skip over comments to reach token, so

;; token beginning is computed by backing up from current

;; position (returned by read-delimited) by string length

(setf beg (if (stringp tok)

(- pos (length tok))

(1- pos)))

(setq tok (classify-token tok beg str errf

+delimiters+ +operators+

+kwstyle+ reserved))

;(display "classify-token-result" tok)

(setf (cdr tail) (list tok ))

(setf tail (cdr tail))

(setq beg pos))))))

|#

;; old tokenize (above) counted delimiters to check for balance,

;; but that does not catch constructions like ({)}. I think

;; we could just leave this up to the parser, but this rewrite

;; uses a stack to check balanced parens, braces, quotes, etc.

;; The checking establishes at least some minimal global properties

;; of the input before evaluating anything, which might be good

;; even though it's doing some extra work. In fact, using a

;; stack rather than counts is doing even more work, but the

;; problem with counters is that some very misleading or just

;; plain wrong error messages got generated.

;;

;; these five delimiter- functions do checks on balanced parens,

;; braces, and brackets, leaving delimiter-mismatch set to bad

;; token if there is a mismatch

(defun delimiter-init ()

(setf delimiter-stack nil)

(setf delimiter-mismatch nil))

(defun delimiter-match (tok what)

(cond ((eql (token-string (first delimiter-stack)) what)

(pop delimiter-stack))

((null delimiter-mismatch)

;(display "delimiter-mismatch" tok)

(setf delimiter-mismatch tok))))

(defun delimiter-check (tok)

(let ((c (token-string tok)))

(cond ((member c '(#\( #\{ #\[))

(push tok delimiter-stack))

((eql c +rbrace+)

(delimiter-match tok +lbrace+))

((eql c +rparen+)

(delimiter-match tok +lparen+))

((eql c +rbrack+)

(delimiter-match tok +lbrack+)))))

(defun delimiter-error (tok)

(errexit (format nil "Unmatched '~A'" (token-string tok))

(token-start tok)))

(defun delimiter-finish ()

(if delimiter-mismatch

(delimiter-error delimiter-mismatch))

(if delimiter-stack

(delimiter-error (car delimiter-stack))))

(defun tokenize (str reserved error-fn)

;; return zero or more tokens or a sal-error

(let ((toks (list t))

(start 0)

(end (length str))

(all-delimiters +whites+)

(errf (or error-fn

(lambda (x) (pperror x) (return-from tokenize x)))))

(dolist (x +delimiters+)

(push (cadr x) all-delimiters))

(delimiter-init)

(do ((beg start)

(pos nil)

(all all-delimiters)

(tok nil)

(tail toks))

((not (< beg end))

;; since input is complete check parens levels.

(delimiter-finish)

(if (null (cdr toks)) nil (cdr toks)))

(setq beg (advance-white str +whites+ beg end))

(setf tok

(read-delimited str :start beg :end end

:white +whites+ :delimit all

:skip-initial-white nil :errorf errf))

;; multiple values are returned, so split them here:

(setf pos (second tok)) ; pos is the end of the token (!)

(setf tok (first tok))

(cond ((eql tok ':eof)

(setq beg end))

(t

;; may have to skip over comments to reach token, so

;; token beginning is computed by backing up from current

;; position (returned by read-delimited) by string length

(setf beg (if (stringp tok)

(- pos (length tok))

(1- pos)))

(setq tok (classify-token tok beg str errf

+delimiters+ +operators+

+kwstyle+ reserved))

(delimiter-check tok)

;(display "classify-token-result" tok)

(setf (cdr tail) (list tok ))

(setf tail (cdr tail))

(setq beg pos))))))

(defun read-delimited (input &key (start 0) end (null-ok t)

(delimit +delims+) ; includes whites...

(white +whites+)

(skip-initial-white t)

(errorf #'pperror))

;; read a substring from input, optionally skipping any white chars

;; first. reading a comment delim equals end-of-line, input delim

;; reads whole input, pound reads next token. call errf if error

;(FORMAT T "~%READ-DELIMITED: ~S :START ~S :END ~S" input start end)

(let ((len (or end (length input))))

(while t ;; loop over comment lines

(when skip-initial-white

(setq start (advance-white input white start len)))

(if (< start len)

(let ((char (char input start)))

(setq end (search-delim input delimit start len))

(if (equal start end) ; have a delimiter

(cond ((char= char +semic+)

;; comment skips to next line and trys again...

(while (and (< start len)

(char/= (char input start) #\newline))

(incf start))

(cond ((< start len) ;; advance past comment and iterate

(incf start)

(setf skip-initial-white t))

(null-ok

(return (list ':eof end)))

(t

(errexit "Unexpected end of input"))))

; ((char= char +pound+)

; ;; read # dispatch

; (read-hash input delimit start len errorf))

((char= char +quote+)

;; input delim reads whole input

(return (sal:read-string input delimit start len errorf)))

((char= char +kwote+)

(errexit "Illegal delimiter" start))

(t ;; all other delimiters are tokens in and of themselves

(return (list char (+ start 1)))))

; else part of (equal start end), so we have token before delimiter

(return (list (subseq input start end) end))))

; else part of (< start len)...

(if null-ok

(return (list ':eof end))

(errexit "Unexpected end of input" start))))))

(defparameter hash-readers

'(( #\t sal:read-bool)

( #\f sal:read-bool)

( #\? read-iftok)

))

(defun read-hash (str delims pos len errf)

(let ((e (+ pos 1)))

(if (< e len)

(let ((a (assoc (char str e) hash-readers)))

(if (not a)

(errexit "Illegal # character" e)

(funcall (cadr a) str delims e len errf)))

(errexit "Missing # character" pos))))

(defun read-iftok (str delims pos len errf)

str delims len errf

(list (make-token :type ':? :string "#?" :lisp 'if

:start (- pos 1))

(+ pos 1)))

; (sal:read-string str start len)

(defun sal:read-bool (str delims pos len errf)

delims len errf

(let ((end (search-delim str delims pos len)))

(unless (= end (+ pos 1))

(errexit "Illegal # expression" (- pos 1)))

(list (let ((t? (char= (char str pos) #\t) ))

(make-token :type ':bool

:string (if t? "#t" "#f")

:lisp t?

:start (- pos 1)))

(+ pos 1))))

(defun sal:read-string (str delims pos len errf)

(let* ((i (1+ pos)) ; i is index into string; start after open quote

c c2; c is the character at str[i]

(string (make-string-output-stream)))

;; read string, processing escaped characters

;; write the chars to string until end quote is found

;; then retrieve the string. quotes are not included in result token

;; in the loop, i is the next character location to examine

(while (and (< i len)

(not (char= (setf c (char str i)) +quote+)))

(if (char= c #\\) ;; escape character, does another character follow this?

(cond ((< (1+ i) len)

(incf i) ;; yes, set i so we'll get the escaped char

(setf c2 (char str i))

(setf c (assoc c2 `((#\n . #\newline) (#\t . #\tab)

(#\r . ,(char "\r" 0))

(#\f . ,(char "\f" 0)))))

(setf c (if c (cdr c) c2))) ;; use c2 if c wasn't listed

(t ;; no, we've hit the end of input too early

(errexit "Unmatched \"" i))))

;; we're good to take this character and move on to the next one

(write-char c string)

(incf i))

;; done with loop, so either we're out of string or we found end quote

(if (>= i len) (errexit "Unmatched \"" i))

;; must have found the quote

(setf string (get-output-stream-string string))

(list (make-token :type :string :start pos :string string :lisp string)

(1+ i))))

;;;

;;; tokens

;;;

(defun make-token (&key (type nil) (string "") start (info nil) lisp)

(list :token type string start info lisp))

(setfn token-type cadr)

(setfn token-string caddr)

(defun token-start (x) (cadddr x))

(defun token-info (token) (car (cddddr token)))

(defun token-lisp (token) (cadr (cddddr token)))

(defmacro set-token-type (tok val) `(setf (car (cdr ,tok)) ,val))

(defmacro set-token-lisp (tok val) `(setf (car (cdr (cddddr ,tok))) ,val))

(defun tokenp (tok) (and (consp tok) (eq (car tok) :token)))

(defun token=? (tok op)

(if (tokenp tok)

(equal (token-type tok) op)

(eql tok op)))

(defmethod token-print (obj stream)

(let ((*print-case* ':downcase))

(format stream "#<~s ~s>"

(token-type obj)

(token-string obj))))

(defun parse-token ()

(prog1 (car *sal-tokens*)

(setf *sal-tokens* (cdr *sal-tokens*))))

;;;

;;; token classification. types not disjoint!

;;;

(defun classify-token (str pos input errf delims ops kstyle res)

(let ((tok nil))

(cond ((characterp str)

;; normalize char delimiter tokens

(setq tok (delimiter-token? str pos input errf delims)))

((stringp str)

(setq tok (or (number-token? str pos input errf)

(operator-token? str pos input errf ops)

(keyword-token? str pos input errf kstyle)

(class-token? str pos input errf res)

(reserved-token? str pos input errf res)

(symbol-token? str pos input errf)

))

(unless tok

(errexit "Not an expression or symbol" pos)))

(t (setq tok str)))

tok))

(defun delimiter-token? (str pos input errf delims)

(let ((typ (member str delims :test (lambda (a b) (char= a (cadr b))))))

;; member returns remainder of the list

;(display "delimiter-token?" str delims typ)

(if (and typ (car typ) (caar typ))

(make-token :type (caar typ) :string str

:start pos)

(+ (break) (errexit "Shouldn't: non-token delimiter" pos)))))

(defun string-to-number (s)

(read (make-string-input-stream s)))

(defun number-token? (str pos input errf)

errf input

(do ((i 0 (+ i 1))

(len (length str))

(c nil)

(dot 0)

(typ ':int)

(sig 0)

(sla 0)

(dig 0)

(non nil))

((or (not (< i len)) non)

(if non nil

(if (> dig 0)

(make-token :type typ :string str

:start pos :lisp (string-to-number str))

nil)))

(setq c (char str i))

(cond ((member c '(#\+ #\-))

(if (> i 0) (setq non t)

(incf sig)))

((char= c #\.)

(if (> dot 0) (setq non t)

(if (> sla 0) (setq non t)

(incf dot))))

; xlisp does not have ratios

; ((char= c #\/)

; (setq typ ':ratio)

; (if (> sla 0) (setq non t)

; (if (= dig 0) (setq non t)

; (if (> dot 0) (setq non t)

; (if (= i (1- len)) (setq non t)

; (incf sla))))))

((digit-char-p c)

(incf dig)

(if (> dot 0) (setq typ ':float)))

(t (setq non t)))))

#||

(number-token? "" 0 "" #'pperror)

(number-token? " " 0 "" #'pperror)

(number-token? "a" 0 "" #'pperror)

(number-token? "1" 0 "" #'pperror)

(number-token? "+" 0 "" #'pperror)

(number-token? "-1/2" 0 "" #'pperror)

(number-token? "1." 0 "" #'pperror)

(number-token? "1.." 0 "" #'pperror)

(number-token? ".1." 0 "" #'pperror)

(number-token? ".1" 0 "" #'pperror)

(number-token? "-0.1" 0 "" #'pperror)

(number-token? "1/2" 0 "" #'pperror)

(number-token? "1//2" 0 "" #'pperror)

(number-token? "/12" 0 "" #'pperror)

(number-token? "12/" 0 "" #'pperror)

(number-token? "12/1" 0 "" #'pperror)

(number-token? "12./1" 0 "" #'pperror)

(number-token? "12/.1" 0 "" #'pperror)

||#

(defun operator-token? (str pos input errf ops)

;; tok can be string or char

(let ((typ (member str ops :test (lambda (a b) (equal a (cadr b))))))

(cond (typ

(setf typ (car typ)) ;; member returns remainder of list

(make-token :type (car typ) :string str

:start pos :lisp (or (third typ)

(read-from-string str)))))))

(defun str-to-keyword (str)

(intern (strcat ":" (string-upcase str))))

(defun keyword-token? (tok pos input errf style)

(let* ((tlen (length tok))

(keys (cdr style))

(klen (length keys)))

(cond ((not (< klen tlen)) nil)

((eql (car style) ':prefix)

(do ((i 0 (+ i 1))

(x nil))

((or (not (< i klen)) x)

(if (not x)

(let ((sym (symbol-token? (subseq tok i)

pos input errf )))

(cond (sym

(set-token-type sym ':key)

(set-token-lisp sym

(str-to-keyword (token-string sym)))

sym)))

nil))

(unless (char= (char tok i) (nth i keys))

(setq x t))))

((eql (car style) ':suffix)

(do ((j (- tlen klen) (+ j 1))

(i 0 (+ i 1))

(x nil))

((or (not (< i klen)) x)

(if (not x)

(let ((sym (symbol-token? (subseq tok 0 (- tlen klen))

pos input errf )))

(cond (sym

(set-token-type sym ':key)

(set-token-lisp sym

(str-to-keyword (token-string sym)))

sym)))

nil))

(unless (char= (char tok j) (nth i keys))

(setq x t)))))))

(setfn alpha-char-p both-case-p)

(defun class-token? (str pos input errf res)

res

(let ((a (char str 0)))

(if (char= a #\<)

(let* ((l (length str))

(b (char str (- l 1))))

(if (char= b #\>)

(let ((tok (symbol-token? (subseq str 1 (- l 1))

pos input errf)))

;; class token has <> removed!

(if tok (progn (set-token-type tok ':class)

tok)

(errexit "Not a class identifer" pos)))

(errexit "Not a class identifer" pos)))

nil)))

; (keyword-token? ":asd" '(:prefix #\:))

; (keyword-token? "asd" KSTYLE)

; (keyword-token? "asd:" KSTYLE)

; (keyword-token? "123:" KSTYLE)

; (keyword-token? ":foo" '(:prefix #\:))

; (keyword-token? "foo=" '(:suffix #\=))

; (keyword-token? "--foo" '(:prefix #\- #\-))

; (keyword-token? ":123" '(:suffix #\:))

; (keyword-token? "--asd" '(:prefix #\-)) ; ok since -asd is legal symbol

(defun reserved-token? (str pos input errf reserved)

errf input

(let ((typ (member str reserved :test (lambda (a b) (equal a (cadr b))))))

(if typ

(make-token :type (caar typ) :string str

:start pos)

nil)))

(defun sal-string-to-symbol (str)

(let ((sym (intern (string-upcase str)))

sal-sym)

(cond ((and sym ;; (it might be "nil")

(setf sal-sym (get sym :sal-name)))

sal-sym)

(t sym))))

(putprop 'simrep 'sal-simrep :sal-name)

(putprop 'seqrep 'sal-seqrep :sal-name)

(defun contains-op-char (s)

;; assume most identifiers are very short, so we search

;; over identifier letters, not over operator characters

;; Minus (-) is so common, we don't complain about it.

(dotimes (i (length s))

(if (string-search (subseq s i (1+ i)) "*/+=<>!%^&|")

(return t))))

(defun test-for-suspicious-symbol (token)

;; assume token is of type :id

(let ((sym (token-lisp token))

(str (token-string token))

(pos (token-start token)))

(cond ((and sym ; nil is not suspicious, but it's not "boundp"

(not (fboundp sym)) ; existing functions not suspicious

(not (boundp sym)) ; existing globals not suspicious

(not (member sym *sal-local-variables*))

(contains-op-char str)) ; suspicious if embedded operators

(sal-warning

(strcat "Identifier contains operator character(s).\n"

" Perhaps you omitted spaces around an operator")

pos)))))

(defun symbol-token? (str pos input errf)

;; if a potential symbol is preceded by #, drop the #

(if (and (> (length str) 1)

(char= (char str 0) #\#))

;; there are a couple of special cases: SAL defines #f and #?

(cond ((equal str "#f")

(return-from symbol-token?

(make-token :type ':id :string str :start pos :lisp nil)))

((equal str "#?")

(return-from symbol-token?

(make-token :type ':id :string str :start pos :lisp 'if)))

(t

(setf str (subseq str 1)))))

;; let's insist on at least one letter for sanity's sake

;; exception: allow '-> because it is used in markov pattern specs

(do ((i 0 (+ i 1)) ; i is index into string

(bad "Not an expression or symbol")

(chr nil)

(ltr 0) ; ltr is count of alphabetic letters in string

(dot nil) ; dot is index of "."

(pkg nil) ; pkg is index if package name "xxx:" found

(len (length str))

(err nil))

;; loop ends when i is at end of string or when err is set

((or (not (< i len)) err)

(if (or (> ltr 0) ; must be at least one letter, or

(equal str "->")) ; symbol can be "->"

(let ((info ()) sym)

(if pkg (push (cons ':pkg pkg) info))

(if dot (push (cons ':slot dot) info))

;(display "in symbol-token?" str)

(setf sym (sal-string-to-symbol str))

(make-token :type ':id :string str

:info info :start pos

:lisp sym))

nil))

(setq chr (char str i))

(cond ((alpha-char-p chr) (incf ltr))

; need to allow arbitrary lisp symbols

; ((member chr '(#\* #\+)) ;; special variable names can start/end

; (if (< 0 i (- len 2)) ;; with + or *

; (errexit bad pos)))

((char= chr #\/) ;; embedded / is not allowed

(errexit bad pos))

;((char= chr #\-) ;; hyphens are allowed anywhere in symbol

; (if (= ltr 0)

; (errexit errf input bad pos )

; (setq ltr 0)

; ))

((char= chr #\:)

; allowable forms are :foo, foo:bar, :foo:bar

(if (> i 0) ;; lisp keyword symbols ok

(cond ((= ltr 0)

(errexit bad pos))

((not pkg)

(setq pkg i))

(t (errexit errf input

(format nil "Too many colons in ~s" str)

pos))))

(setq ltr 0))

((char= chr #\.)

(if (or dot (= i 0) (= i (- len 1)))

(errexit bad pos)

(progn (setq dot i) (setq ltr 0)))))))

; (let ((i "foo")) (symbol-token? i 0 i #'pperror))

; (let ((i "foo..bar")) (symbol-token? i 0 i #'pperror))

; (let ((i ".bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "bar.")) (symbol-token? i 0 i #'pperror))

; (let ((i "1...")) (symbol-token? i 0 i #'pperror))

; (let ((i "a1..." )) (symbol-token? i 0 i #'pperror))

; (let ((i "a{b")) (symbol-token? i 0 i #'pperror))

; (let ((i "foo-bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "123-a")) (symbol-token? i 0 i #'pperror))

; (let ((i "1a23-a")) (symbol-token? i 0 i #'pperror))

; (let ((i "*foo*")) (symbol-token? i 0 i #'pperror))

; (let ((i "+foo+")) (symbol-token? i 0 i #'pperror))

; (let ((i "foo+bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "foo/bar")) (symbol-token? i 0 i #'pperror))

; (let ((i ":bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "::bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "foo:bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "cl-user:bar")) (symbol-token? i 0 i #'pperror))

; (let ((i "cl-user::bar")) (symbol-token? i 0 i #'pperror))

; (tokenize "aaa + bbb \"asdasdd\" aaa(1,2,3)")

; (tokenize "aaa+bbb \"asdasdd\" aaa(1,2,3)")

(setf *in-sal-parser* nil)

;; line number info for debugging

(setf *sal-line-number-info* t)

(setf *sal-line* 0)

(defun add-line-info-to-expression (expr token)

(let (line-no)

(cond ((and token ;; null token means do not change expr

*sal-line-number-info* ;; is this feature enabled?

(stringp *sal-input-text*))

;; first, get line number

(setf line-no (pos-to-line (token-start token) *sal-input-text*))

`(prog2 (setf *sal-line* ,line-no) ,expr))

(t expr))))

;; single statement is handled just like an expression

(setfn add-line-info-to-stmt add-line-info-to-expression)

;; list of statements is simple to handle: prepend SETF

(defun add-line-info-to-stmts (stmts token)

(let (line-no)

(cond ((and *sal-line-number-info* ;; is this feature enabled?

(stringp *sal-input-text*))

(setf line-no (pos-to-line (token-start token) *sal-input-text*))

(cons `(setf *sal-line* ,line-no) stmts))

(t stmts))))

;; PARSE-ERROR -- print error message, return from top-level

;;

(defun parse-error (e)

(unless (sal-error-line e)

(setf (sal-error-line e) *sal-input*))

(pperror e)

(return-from sal-parse (values nil e *sal-tokens*)))

;; SAL-PARSE -- parse string or token input, translate to Lisp

;;

;; If input is text, *sal-input-text* is set to the text and

;; read later (maybe) by ERREXIT.

;; If input is a token list, it is assumed these are leftovers

;; from tokenized text, so *sal-input-text* is already valid.

;; *Therfore*, do not call sal-parse with tokens unless

;; *sal-input-text* is set to the corresponding text.

;;

(defun sal-parse (grammar pat input multiple-statements file)

(progv '(*sal-input-file-name*) (list file)

(let (rslt expr rest)

; ignore grammar and pat (just there for compatibility)

; parse input and return lisp expression

(cond ((stringp input)

(setf *sal-input-text* input)

(setq input (tokenize input *reserved-words* #'parse-error))))

(setf *sal-input* input) ;; all input

(setf *sal-tokens* input) ;; current input

(cond ((null input)

(values t nil nil)) ; e.g. comments compile to nil

(t

(setf rslt (or (maybe-parse-command)

(maybe-parse-block)

(maybe-parse-conditional)

(maybe-parse-assignment)

(maybe-parse-loop)

(maybe-parse-exec)

(maybe-parse-exit)

(errexit "Syntax error")))

;; note: there is a return-from parse in parse-error that

;; returns (values nil error <unparsed-tokens>)

(cond ((and *sal-tokens* (not multiple-statements))

(errexit "leftover tokens")))

;((null rslt)

; (errexit "nothing to compile")))

(values t rslt *sal-tokens*))))))