giles
5ef07a4d8d
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
949 lines
34 KiB
Plaintext
949 lines
34 KiB
Plaintext
;; Smalltalk parser — produces an AST from the tokenizer's token stream.
|
|
;;
|
|
;; AST node shapes (dicts):
|
|
;; {:type "lit-int" :value N} integer
|
|
;; {:type "lit-float" :value F} float
|
|
;; {:type "lit-string" :value S} string
|
|
;; {:type "lit-char" :value C} character
|
|
;; {:type "lit-symbol" :value S} symbol literal (#foo)
|
|
;; {:type "lit-array" :elements (list ...)} literal array (#(1 2 #foo))
|
|
;; {:type "lit-byte-array" :elements (...)} byte array (#[1 2 3])
|
|
;; {:type "lit-nil" } / "lit-true" / "lit-false"
|
|
;; {:type "ident" :name "x"} variable reference
|
|
;; {:type "self"} / "super" / "thisContext" pseudo-variables
|
|
;; {:type "assign" :name "x" :expr E} x := E
|
|
;; {:type "return" :expr E} ^ E
|
|
;; {:type "send" :receiver R :selector S :args (list ...)}
|
|
;; {:type "cascade" :receiver R :messages (list {:selector :args} ...)}
|
|
;; {:type "block" :params (list "a") :temps (list "t") :body (list expr)}
|
|
;; {:type "seq" :exprs (list ...)} statement sequence
|
|
;; {:type "method" :selector S :params (list ...) :temps (list ...) :body (list ...) :pragmas (list ...)}
|
|
;;
|
|
;; A "chunk" / class-definition stream is parsed at a higher level (deferred).
|
|
|
|
;; ── Chunk-stream reader ────────────────────────────────────────────────
|
|
;; Pharo chunk format: chunks are separated by `!`. A doubled `!!` inside a
|
|
;; chunk represents a single literal `!`. Returns list of chunk strings with
|
|
;; surrounding whitespace trimmed.
|
|
(define
|
|
st-read-chunks
|
|
(fn
|
|
(src)
|
|
(let
|
|
((chunks (list))
|
|
(buf (list))
|
|
(pos 0)
|
|
(n (len src)))
|
|
(begin
|
|
(define
|
|
flush!
|
|
(fn
|
|
()
|
|
(let
|
|
((s (st-trim (join "" buf))))
|
|
(begin (append! chunks s) (set! buf (list))))))
|
|
(define
|
|
rc-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< pos n)
|
|
(let
|
|
((c (nth src pos)))
|
|
(cond
|
|
((= c "!")
|
|
(cond
|
|
((and (< (+ pos 1) n) (= (nth src (+ pos 1)) "!"))
|
|
(begin (append! buf "!") (set! pos (+ pos 2)) (rc-loop)))
|
|
(else
|
|
(begin (flush!) (set! pos (+ pos 1)) (rc-loop)))))
|
|
(else
|
|
(begin (append! buf c) (set! pos (+ pos 1)) (rc-loop))))))))
|
|
(rc-loop)
|
|
;; trailing text without a closing `!` — preserve as a chunk
|
|
(when (> (len buf) 0) (flush!))
|
|
chunks))))
|
|
|
|
(define
|
|
st-trim
|
|
(fn
|
|
(s)
|
|
(let
|
|
((n (len s)) (i 0) (j 0))
|
|
(begin
|
|
(set! j n)
|
|
(define
|
|
tl-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(and (< i n) (st-trim-ws? (nth s i)))
|
|
(begin (set! i (+ i 1)) (tl-loop)))))
|
|
(tl-loop)
|
|
(define
|
|
tr-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(and (> j i) (st-trim-ws? (nth s (- j 1))))
|
|
(begin (set! j (- j 1)) (tr-loop)))))
|
|
(tr-loop)
|
|
(slice s i j)))))
|
|
|
|
(define
|
|
st-trim-ws?
|
|
(fn (c) (or (= c " ") (= c "\t") (= c "\n") (= c "\r"))))
|
|
|
|
;; Parse a chunk stream. Walks chunks and applies the Pharo file-in
|
|
;; convention: a chunk that evaluates to "X methodsFor: 'cat'" or
|
|
;; "X class methodsFor: 'cat'" enters a methods batch — subsequent chunks
|
|
;; are method source until an empty chunk closes the batch.
|
|
;;
|
|
;; Returns list of entries:
|
|
;; {:kind "expr" :ast EXPR-AST}
|
|
;; {:kind "method" :class CLS :class-side? BOOL :category CAT :ast METHOD-AST}
|
|
;; {:kind "blank"} (empty chunks outside a methods batch)
|
|
;; {:kind "end-methods"} (empty chunk closing a methods batch)
|
|
(define
|
|
st-parse-chunks
|
|
(fn
|
|
(src)
|
|
(let
|
|
((chunks (st-read-chunks src))
|
|
(entries (list))
|
|
(mode "do-it")
|
|
(cls-name nil)
|
|
(class-side? false)
|
|
(category nil))
|
|
(begin
|
|
(for-each
|
|
(fn
|
|
(chunk)
|
|
(cond
|
|
((= chunk "")
|
|
(cond
|
|
((= mode "methods")
|
|
(begin
|
|
(append! entries {:kind "end-methods"})
|
|
(set! mode "do-it")
|
|
(set! cls-name nil)
|
|
(set! class-side? false)
|
|
(set! category nil)))
|
|
(else (append! entries {:kind "blank"}))))
|
|
((= mode "methods")
|
|
(append!
|
|
entries
|
|
{:kind "method"
|
|
:class cls-name
|
|
:class-side? class-side?
|
|
:category category
|
|
:ast (st-parse-method chunk)}))
|
|
(else
|
|
(let
|
|
((ast (st-parse-expr chunk)))
|
|
(begin
|
|
(append! entries {:kind "expr" :ast ast})
|
|
(let
|
|
((mf (st-detect-methods-for ast)))
|
|
(when
|
|
(not (= mf nil))
|
|
(begin
|
|
(set! mode "methods")
|
|
(set! cls-name (get mf :class))
|
|
(set! class-side? (get mf :class-side?))
|
|
(set! category (get mf :category))))))))))
|
|
chunks)
|
|
entries))))
|
|
|
|
;; Recognise `Foo methodsFor: 'cat'` (and related) as starting a methods batch.
|
|
;; Returns nil if the AST doesn't look like one of these forms.
|
|
(define
|
|
st-detect-methods-for
|
|
(fn
|
|
(ast)
|
|
(cond
|
|
((not (= (get ast :type) "send")) nil)
|
|
((not (st-is-methods-for-selector? (get ast :selector))) nil)
|
|
(else
|
|
(let
|
|
((recv (get ast :receiver)) (args (get ast :args)))
|
|
(let
|
|
((cat-arg (if (> (len args) 0) (nth args 0) nil)))
|
|
(let
|
|
((category
|
|
(cond
|
|
((= cat-arg nil) nil)
|
|
((= (get cat-arg :type) "lit-string") (get cat-arg :value))
|
|
((= (get cat-arg :type) "lit-symbol") (get cat-arg :value))
|
|
(else nil))))
|
|
(cond
|
|
((= (get recv :type) "ident")
|
|
{:class (get recv :name)
|
|
:class-side? false
|
|
:category category})
|
|
;; `Foo class methodsFor: 'cat'` — recv is a unary send `Foo class`
|
|
((and
|
|
(= (get recv :type) "send")
|
|
(= (get recv :selector) "class")
|
|
(= (get (get recv :receiver) :type) "ident"))
|
|
{:class (get (get recv :receiver) :name)
|
|
:class-side? true
|
|
:category category})
|
|
(else nil)))))))))
|
|
|
|
(define
|
|
st-is-methods-for-selector?
|
|
(fn
|
|
(sel)
|
|
(or
|
|
(= sel "methodsFor:")
|
|
(= sel "methodsFor:stamp:")
|
|
(= sel "category:"))))
|
|
|
|
(define st-tok-type (fn (t) (if (= t nil) "eof" (get t :type))))
|
|
|
|
(define st-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
|
|
|
;; Parse a *single* Smalltalk expression from source.
|
|
(define st-parse-expr (fn (src) (st-parse-with src "expr")))
|
|
|
|
;; Parse a sequence of statements separated by '.' Returns a {:type "seq"} node.
|
|
(define st-parse (fn (src) (st-parse-with src "seq")))
|
|
|
|
;; Parse a method body — `selector params | temps | body`.
|
|
;; Only the "method header + body" form (no chunk delimiters).
|
|
(define st-parse-method (fn (src) (st-parse-with src "method")))
|
|
|
|
(define
|
|
st-parse-with
|
|
(fn
|
|
(src mode)
|
|
(let
|
|
((tokens (st-tokenize src)) (idx 0) (tok-len 0))
|
|
(begin
|
|
(set! tok-len (len tokens))
|
|
(define peek-tok (fn () (nth tokens idx)))
|
|
(define
|
|
peek-tok-at
|
|
(fn (n) (if (< (+ idx n) tok-len) (nth tokens (+ idx n)) nil)))
|
|
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
|
(define
|
|
at?
|
|
(fn
|
|
(type value)
|
|
(let
|
|
((t (peek-tok)))
|
|
(and
|
|
(= (st-tok-type t) type)
|
|
(or (= value nil) (= (st-tok-value t) value))))))
|
|
(define at-type? (fn (type) (= (st-tok-type (peek-tok)) type)))
|
|
(define
|
|
consume!
|
|
(fn
|
|
(type value)
|
|
(if
|
|
(at? type value)
|
|
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
|
(error
|
|
(str
|
|
"st-parse: expected "
|
|
type
|
|
(if (= value nil) "" (str " '" value "'"))
|
|
" got "
|
|
(st-tok-type (peek-tok))
|
|
" '"
|
|
(st-tok-value (peek-tok))
|
|
"' at idx "
|
|
idx)))))
|
|
|
|
;; ── Primary: atoms, paren'd expr, blocks, literal arrays, byte arrays.
|
|
(define
|
|
parse-primary
|
|
(fn
|
|
()
|
|
(let
|
|
((t (peek-tok)))
|
|
(let
|
|
((ty (st-tok-type t)) (v (st-tok-value t)))
|
|
(cond
|
|
((= ty "number")
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((number? v) {:type (if (integer? v) "lit-int" "lit-float") :value v})
|
|
(else {:type "lit-int" :value v}))))
|
|
((= ty "string")
|
|
(begin (advance-tok!) {:type "lit-string" :value v}))
|
|
((= ty "char")
|
|
(begin (advance-tok!) {:type "lit-char" :value v}))
|
|
((= ty "symbol")
|
|
(begin (advance-tok!) {:type "lit-symbol" :value v}))
|
|
((= ty "array-open") (parse-literal-array))
|
|
((= ty "byte-array-open") (parse-byte-array))
|
|
((= ty "lparen")
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((e (parse-expression)))
|
|
(begin (consume! "rparen" nil) e))))
|
|
((= ty "lbracket") (parse-block))
|
|
((= ty "lbrace") (parse-dynamic-array))
|
|
((= ty "ident")
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((= v "nil") {:type "lit-nil"})
|
|
((= v "true") {:type "lit-true"})
|
|
((= v "false") {:type "lit-false"})
|
|
((= v "self") {:type "self"})
|
|
((= v "super") {:type "super"})
|
|
((= v "thisContext") {:type "thisContext"})
|
|
(else {:type "ident" :name v}))))
|
|
((= ty "binary")
|
|
;; Negative numeric literal: '-' immediately before a number.
|
|
(cond
|
|
((and (= v "-") (= (st-tok-type (peek-tok-at 1)) "number"))
|
|
(let
|
|
((n (st-tok-value (peek-tok-at 1))))
|
|
(begin
|
|
(advance-tok!)
|
|
(advance-tok!)
|
|
(cond
|
|
((dict? n) {:type "lit-int" :value n})
|
|
((integer? n) {:type "lit-int" :value (- 0 n)})
|
|
(else {:type "lit-float" :value (- 0 n)})))))
|
|
(else
|
|
(error
|
|
(str "st-parse: unexpected binary '" v "' at idx " idx)))))
|
|
(else
|
|
(error
|
|
(str
|
|
"st-parse: unexpected "
|
|
ty
|
|
" '"
|
|
v
|
|
"' at idx "
|
|
idx))))))))
|
|
|
|
;; #(elem elem ...) — elements are atoms or nested parenthesised arrays.
|
|
(define
|
|
parse-literal-array
|
|
(fn
|
|
()
|
|
(let
|
|
((items (list)))
|
|
(begin
|
|
(consume! "array-open" nil)
|
|
(define
|
|
arr-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((at? "rparen" nil) (advance-tok!))
|
|
(else
|
|
(begin
|
|
(append! items (parse-array-element))
|
|
(arr-loop))))))
|
|
(arr-loop)
|
|
{:type "lit-array" :elements items}))))
|
|
|
|
;; { expr. expr. expr } — Pharo dynamic array literal. Each element
|
|
;; is a *full expression* evaluated at runtime; the result is a
|
|
;; fresh mutable array. Empty `{}` is a 0-length array.
|
|
(define
|
|
parse-dynamic-array
|
|
(fn
|
|
()
|
|
(let ((items (list)))
|
|
(begin
|
|
(consume! "lbrace" nil)
|
|
(define
|
|
da-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((at? "rbrace" nil) (advance-tok!))
|
|
(else
|
|
(begin
|
|
(append! items (parse-expression))
|
|
(define
|
|
dot-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at? "period" nil)
|
|
(begin (advance-tok!) (dot-loop)))))
|
|
(dot-loop)
|
|
(da-loop))))))
|
|
(da-loop)
|
|
{:type "dynamic-array" :elements items}))))
|
|
|
|
;; #[1 2 3]
|
|
(define
|
|
parse-byte-array
|
|
(fn
|
|
()
|
|
(let
|
|
((items (list)))
|
|
(begin
|
|
(consume! "byte-array-open" nil)
|
|
(define
|
|
ba-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((at? "rbracket" nil) (advance-tok!))
|
|
(else
|
|
(let
|
|
((t (peek-tok)))
|
|
(cond
|
|
((= (st-tok-type t) "number")
|
|
(begin
|
|
(advance-tok!)
|
|
(append! items (st-tok-value t))
|
|
(ba-loop)))
|
|
(else
|
|
(error
|
|
(str
|
|
"st-parse: byte array expects number, got "
|
|
(st-tok-type t))))))))))
|
|
(ba-loop)
|
|
{:type "lit-byte-array" :elements items}))))
|
|
|
|
;; Inside a literal array: bare idents become symbols, nested (...) is a sub-array.
|
|
(define
|
|
parse-array-element
|
|
(fn
|
|
()
|
|
(let
|
|
((t (peek-tok)))
|
|
(let
|
|
((ty (st-tok-type t)) (v (st-tok-value t)))
|
|
(cond
|
|
((= ty "number") (begin (advance-tok!) {:type "lit-int" :value v}))
|
|
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
|
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
|
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
|
((= ty "ident")
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((= v "nil") {:type "lit-nil"})
|
|
((= v "true") {:type "lit-true"})
|
|
((= v "false") {:type "lit-false"})
|
|
(else {:type "lit-symbol" :value v}))))
|
|
((= ty "keyword") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
|
((= ty "binary") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
|
((= ty "lparen")
|
|
(let ((items (list)))
|
|
(begin
|
|
(advance-tok!)
|
|
(define
|
|
sub-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((at? "rparen" nil) (advance-tok!))
|
|
(else
|
|
(begin (append! items (parse-array-element)) (sub-loop))))))
|
|
(sub-loop)
|
|
{:type "lit-array" :elements items})))
|
|
((= ty "array-open") (parse-literal-array))
|
|
((= ty "byte-array-open") (parse-byte-array))
|
|
(else
|
|
(error
|
|
(str "st-parse: bad literal-array element " ty " '" v "'"))))))))
|
|
|
|
;; [:a :b | | t1 t2 | body. body. ...]
|
|
(define
|
|
parse-block
|
|
(fn
|
|
()
|
|
(begin
|
|
(consume! "lbracket" nil)
|
|
(let
|
|
((params (list)) (temps (list)))
|
|
(begin
|
|
;; Block params
|
|
(define
|
|
p-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at? "colon" nil)
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((t (consume! "ident" nil)))
|
|
(begin
|
|
(append! params (st-tok-value t))
|
|
(p-loop)))))))
|
|
(p-loop)
|
|
(when (> (len params) 0) (consume! "bar" nil))
|
|
;; Block temps: | t1 t2 |
|
|
(when
|
|
(and
|
|
(at? "bar" nil)
|
|
;; Not `|` followed immediately by binary content — the only
|
|
;; legitimate `|` inside a block here is the temp delimiter.
|
|
true)
|
|
(begin
|
|
(advance-tok!)
|
|
(define
|
|
t-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at? "ident" nil)
|
|
(let
|
|
((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! temps (st-tok-value t))
|
|
(t-loop))))))
|
|
(t-loop)
|
|
(consume! "bar" nil)))
|
|
;; Body: statements terminated by `.` or `]`
|
|
(let
|
|
((body (parse-statements "rbracket")))
|
|
(begin
|
|
(consume! "rbracket" nil)
|
|
{:type "block" :params params :temps temps :body body})))))))
|
|
|
|
;; Parse statements up to a closing token (rbracket or eof). Returns list.
|
|
(define
|
|
parse-statements
|
|
(fn
|
|
(terminator)
|
|
(let
|
|
((stmts (list)))
|
|
(begin
|
|
(define
|
|
s-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((at-type? terminator) nil)
|
|
((at-type? "eof") nil)
|
|
(else
|
|
(begin
|
|
(append! stmts (parse-statement))
|
|
;; consume optional period(s)
|
|
(define
|
|
dot-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at? "period" nil)
|
|
(begin (advance-tok!) (dot-loop)))))
|
|
(dot-loop)
|
|
(s-loop))))))
|
|
(s-loop)
|
|
stmts))))
|
|
|
|
;; Statement: ^expr | ident := expr | expr
|
|
(define
|
|
parse-statement
|
|
(fn
|
|
()
|
|
(cond
|
|
((at? "caret" nil)
|
|
(begin
|
|
(advance-tok!)
|
|
{:type "return" :expr (parse-expression)}))
|
|
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
|
(let
|
|
((name-tok (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(advance-tok!)
|
|
{:type "assign"
|
|
:name (st-tok-value name-tok)
|
|
:expr (parse-expression)})))
|
|
(else (parse-expression)))))
|
|
|
|
;; Top-level expression. Assignment (right-associative chain) sits at
|
|
;; the top; cascade is below.
|
|
(define
|
|
parse-expression
|
|
(fn
|
|
()
|
|
(cond
|
|
((and (at-type? "ident") (= (st-tok-type (peek-tok-at 1)) "assign"))
|
|
(let
|
|
((name-tok (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(advance-tok!)
|
|
{:type "assign"
|
|
:name (st-tok-value name-tok)
|
|
:expr (parse-expression)})))
|
|
(else (parse-cascade)))))
|
|
|
|
(define
|
|
parse-cascade
|
|
(fn
|
|
()
|
|
(let
|
|
((head (parse-keyword-message)))
|
|
(cond
|
|
((at? "semi" nil)
|
|
(let
|
|
((receiver (cascade-receiver head))
|
|
(first-msg (cascade-first-message head))
|
|
(msgs (list)))
|
|
(begin
|
|
(append! msgs first-msg)
|
|
(define
|
|
c-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at? "semi" nil)
|
|
(begin
|
|
(advance-tok!)
|
|
(append! msgs (parse-cascade-message))
|
|
(c-loop)))))
|
|
(c-loop)
|
|
{:type "cascade" :receiver receiver :messages msgs})))
|
|
(else head)))))
|
|
|
|
;; Extract the receiver from a head send so cascades share it.
|
|
(define
|
|
cascade-receiver
|
|
(fn
|
|
(head)
|
|
(cond
|
|
((= (get head :type) "send") (get head :receiver))
|
|
(else head))))
|
|
|
|
(define
|
|
cascade-first-message
|
|
(fn
|
|
(head)
|
|
(cond
|
|
((= (get head :type) "send")
|
|
{:selector (get head :selector) :args (get head :args)})
|
|
(else
|
|
;; Shouldn't happen — cascade requires at least one prior message.
|
|
(error "st-parse: cascade with no prior message")))))
|
|
|
|
;; Subsequent cascade message (after the `;`): unary | binary | keyword
|
|
(define
|
|
parse-cascade-message
|
|
(fn
|
|
()
|
|
(cond
|
|
((at-type? "ident")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
{:selector (st-tok-value t) :args (list)})))
|
|
((at-type? "binary")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((arg (parse-unary-message)))
|
|
{:selector (st-tok-value t) :args (list arg)}))))
|
|
((at-type? "keyword")
|
|
(let
|
|
((sel-parts (list)) (args (list)))
|
|
(begin
|
|
(define
|
|
kw-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "keyword")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! sel-parts (st-tok-value t))
|
|
(append! args (parse-binary-message))
|
|
(kw-loop))))))
|
|
(kw-loop)
|
|
{:selector (join "" sel-parts) :args args})))
|
|
(else
|
|
(error
|
|
(str "st-parse: bad cascade message at idx " idx))))))
|
|
|
|
;; Keyword message: <binary> (kw <binary>)+
|
|
(define
|
|
parse-keyword-message
|
|
(fn
|
|
()
|
|
(let
|
|
((receiver (parse-binary-message)))
|
|
(cond
|
|
((at-type? "keyword")
|
|
(let
|
|
((sel-parts (list)) (args (list)))
|
|
(begin
|
|
(define
|
|
kw-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "keyword")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! sel-parts (st-tok-value t))
|
|
(append! args (parse-binary-message))
|
|
(kw-loop))))))
|
|
(kw-loop)
|
|
{:type "send"
|
|
:receiver receiver
|
|
:selector (join "" sel-parts)
|
|
:args args})))
|
|
(else receiver)))))
|
|
|
|
;; Binary message: <unary> (binop <unary>)*
|
|
;; A bare `|` is also a legitimate binary selector (logical or in
|
|
;; some Smalltalks); the tokenizer emits it as the `bar` type so
|
|
;; that block-param / temp-decl delimiters are easy to spot.
|
|
;; In expression position, accept it as a binary operator.
|
|
(define
|
|
parse-binary-message
|
|
(fn
|
|
()
|
|
(let
|
|
((receiver (parse-unary-message)))
|
|
(begin
|
|
(define
|
|
b-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(or (at-type? "binary") (at-type? "bar"))
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((arg (parse-unary-message)))
|
|
(set!
|
|
receiver
|
|
{:type "send"
|
|
:receiver receiver
|
|
:selector (st-tok-value t)
|
|
:args (list arg)}))
|
|
(b-loop))))))
|
|
(b-loop)
|
|
receiver))))
|
|
|
|
;; Unary message: <primary> ident* (ident NOT followed by ':')
|
|
(define
|
|
parse-unary-message
|
|
(fn
|
|
()
|
|
(let
|
|
((receiver (parse-primary)))
|
|
(begin
|
|
(define
|
|
u-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(and
|
|
(at-type? "ident")
|
|
(let
|
|
((nxt (peek-tok-at 1)))
|
|
(not (= (st-tok-type nxt) "assign"))))
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(set!
|
|
receiver
|
|
{:type "send"
|
|
:receiver receiver
|
|
:selector (st-tok-value t)
|
|
:args (list)})
|
|
(u-loop))))))
|
|
(u-loop)
|
|
receiver))))
|
|
|
|
;; Parse a single pragma: `<keyword: literal (keyword: literal)* >`
|
|
;; Returns {:selector "primitive:" :args (list literal-asts)}.
|
|
(define
|
|
parse-pragma
|
|
(fn
|
|
()
|
|
(begin
|
|
(consume! "binary" "<")
|
|
(let
|
|
((sel-parts (list)) (args (list)))
|
|
(begin
|
|
(define
|
|
pr-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "keyword")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! sel-parts (st-tok-value t))
|
|
(append! args (parse-pragma-arg))
|
|
(pr-loop))))))
|
|
(pr-loop)
|
|
(consume! "binary" ">")
|
|
{:selector (join "" sel-parts) :args args})))))
|
|
|
|
;; Pragma arguments are literals only.
|
|
(define
|
|
parse-pragma-arg
|
|
(fn
|
|
()
|
|
(let
|
|
((t (peek-tok)))
|
|
(let
|
|
((ty (st-tok-type t)) (v (st-tok-value t)))
|
|
(cond
|
|
((= ty "number")
|
|
(begin
|
|
(advance-tok!)
|
|
{:type (if (integer? v) "lit-int" "lit-float") :value v}))
|
|
((= ty "string") (begin (advance-tok!) {:type "lit-string" :value v}))
|
|
((= ty "char") (begin (advance-tok!) {:type "lit-char" :value v}))
|
|
((= ty "symbol") (begin (advance-tok!) {:type "lit-symbol" :value v}))
|
|
((= ty "ident")
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((= v "nil") {:type "lit-nil"})
|
|
((= v "true") {:type "lit-true"})
|
|
((= v "false") {:type "lit-false"})
|
|
(else (error (str "st-parse: pragma arg must be literal, got ident " v))))))
|
|
((and (= ty "binary") (= v "-")
|
|
(= (st-tok-type (peek-tok-at 1)) "number"))
|
|
(let ((n (st-tok-value (peek-tok-at 1))))
|
|
(begin
|
|
(advance-tok!)
|
|
(advance-tok!)
|
|
{:type (if (integer? n) "lit-int" "lit-float")
|
|
:value (- 0 n)})))
|
|
(else
|
|
(error
|
|
(str "st-parse: pragma arg must be literal, got " ty))))))))
|
|
|
|
;; Method header: unary | binary arg | (kw arg)+
|
|
(define
|
|
parse-method
|
|
(fn
|
|
()
|
|
(let
|
|
((sel "")
|
|
(params (list))
|
|
(temps (list))
|
|
(pragmas (list))
|
|
(body (list)))
|
|
(begin
|
|
(cond
|
|
;; Unary header
|
|
((at-type? "ident")
|
|
(let ((t (peek-tok)))
|
|
(begin (advance-tok!) (set! sel (st-tok-value t)))))
|
|
;; Binary header: binop ident
|
|
((at-type? "binary")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(set! sel (st-tok-value t))
|
|
(let ((p (consume! "ident" nil)))
|
|
(append! params (st-tok-value p))))))
|
|
;; Keyword header: (kw ident)+
|
|
((at-type? "keyword")
|
|
(let ((sel-parts (list)))
|
|
(begin
|
|
(define
|
|
kh-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "keyword")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! sel-parts (st-tok-value t))
|
|
(let ((p (consume! "ident" nil)))
|
|
(append! params (st-tok-value p)))
|
|
(kh-loop))))))
|
|
(kh-loop)
|
|
(set! sel (join "" sel-parts)))))
|
|
(else
|
|
(error
|
|
(str
|
|
"st-parse-method: expected selector header, got "
|
|
(st-tok-type (peek-tok))))))
|
|
;; Pragmas and temps may appear in either order. Allow many
|
|
;; pragmas; one temps section.
|
|
(define
|
|
parse-temps!
|
|
(fn
|
|
()
|
|
(begin
|
|
(advance-tok!)
|
|
(define
|
|
th-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "ident")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! temps (st-tok-value t))
|
|
(th-loop))))))
|
|
(th-loop)
|
|
(consume! "bar" nil))))
|
|
(define
|
|
pt-loop
|
|
(fn
|
|
()
|
|
(cond
|
|
((and
|
|
(at? "binary" "<")
|
|
(= (st-tok-type (peek-tok-at 1)) "keyword"))
|
|
(begin (append! pragmas (parse-pragma)) (pt-loop)))
|
|
((and (at? "bar" nil) (= (len temps) 0))
|
|
(begin (parse-temps!) (pt-loop)))
|
|
(else nil))))
|
|
(pt-loop)
|
|
;; Body statements
|
|
(set! body (parse-statements "eof"))
|
|
{:type "method"
|
|
:selector sel
|
|
:params params
|
|
:temps temps
|
|
:pragmas pragmas
|
|
:body body}))))
|
|
|
|
;; Top-level program: optional temp declaration, then statements
|
|
;; separated by '.'. Pharo workspace-style scripts allow
|
|
;; `| temps | body...` at the top level.
|
|
(cond
|
|
((= mode "expr") (parse-expression))
|
|
((= mode "method") (parse-method))
|
|
(else
|
|
(let ((temps (list)))
|
|
(begin
|
|
(when
|
|
(at? "bar" nil)
|
|
(begin
|
|
(advance-tok!)
|
|
(define
|
|
tt-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-type? "ident")
|
|
(let ((t (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(append! temps (st-tok-value t))
|
|
(tt-loop))))))
|
|
(tt-loop)
|
|
(consume! "bar" nil)))
|
|
{:type "seq" :temps temps :exprs (parse-statements "eof")}))))))))
|