giles
c8d7fdd59a
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 16s
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
571 lines
17 KiB
Plaintext
571 lines
17 KiB
Plaintext
; Tcl-on-SX runtime evaluator
|
|
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
|
|
|
|
(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
|
|
|
|
(define
|
|
frame-lookup
|
|
(fn
|
|
(frame name)
|
|
(if
|
|
(nil? frame)
|
|
nil
|
|
(let
|
|
((val (get (get frame :locals) name)))
|
|
(if (nil? val) (frame-lookup (get frame :parent) name) val)))))
|
|
|
|
(define
|
|
frame-set-top
|
|
(fn
|
|
(frame name val)
|
|
(assoc frame :locals (assoc (get frame :locals) name val))))
|
|
|
|
(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :commands {}}))
|
|
|
|
(define
|
|
tcl-register
|
|
(fn
|
|
(interp name f)
|
|
(assoc interp :commands (assoc (get interp :commands) name f))))
|
|
|
|
(define
|
|
tcl-var-get
|
|
(fn
|
|
(interp name)
|
|
(let
|
|
((val (frame-lookup (get interp :frame) name)))
|
|
(if
|
|
(nil? val)
|
|
(error (str "can't read \"" name "\": no such variable"))
|
|
val))))
|
|
|
|
(define
|
|
tcl-var-set
|
|
(fn
|
|
(interp name val)
|
|
(assoc interp :frame (frame-set-top (get interp :frame) name val))))
|
|
|
|
(define
|
|
tcl-eval-parts
|
|
(fn
|
|
(parts interp)
|
|
(reduce
|
|
(fn
|
|
(acc part)
|
|
(let
|
|
((type (get part :type)) (cur-interp (get acc :interp)))
|
|
(cond
|
|
((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
|
|
((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
|
|
((equal? type "var-arr")
|
|
(let
|
|
((key-acc (tcl-eval-parts (get part :key) cur-interp)))
|
|
(let
|
|
((key (join "" (get key-acc :values)))
|
|
(next-interp (get key-acc :interp)))
|
|
{:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
|
|
((equal? type "cmd")
|
|
(let
|
|
((new-interp (tcl-eval-string cur-interp (get part :src))))
|
|
{:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
|
|
(else (error (str "tcl: unknown part type: " type))))))
|
|
{:values (quote ()) :interp interp}
|
|
parts)))
|
|
|
|
(define
|
|
tcl-eval-word
|
|
(fn
|
|
(word interp)
|
|
(let
|
|
((type (get word :type)))
|
|
(cond
|
|
((equal? type "braced") {:interp interp :value (get word :value)})
|
|
((equal? type "compound")
|
|
(let
|
|
((result (tcl-eval-parts (get word :parts) interp)))
|
|
{:interp (get result :interp) :value (join "" (get result :values))}))
|
|
((equal? type "expand") (tcl-eval-word (get word :word) interp))
|
|
(else (error (str "tcl: unknown word type: " type)))))))
|
|
|
|
(define
|
|
tcl-list-split
|
|
(fn
|
|
(s)
|
|
(define chars (split s ""))
|
|
(define len-s (len chars))
|
|
(define
|
|
go
|
|
(fn
|
|
(i acc cur-item depth)
|
|
(if
|
|
(>= i len-s)
|
|
(if (> (len cur-item) 0) (append acc (list cur-item)) acc)
|
|
(let
|
|
((c (nth chars i)))
|
|
(cond
|
|
((equal? c "{")
|
|
(if
|
|
(= depth 0)
|
|
(go (+ i 1) acc "" (+ depth 1))
|
|
(go (+ i 1) acc (str cur-item c) (+ depth 1))))
|
|
((equal? c "}")
|
|
(if
|
|
(= depth 1)
|
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
|
(go (+ i 1) acc (str cur-item c) (- depth 1))))
|
|
((equal? c " ")
|
|
(if
|
|
(and (= depth 0) (> (len cur-item) 0))
|
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
|
(go
|
|
(+ i 1)
|
|
acc
|
|
(if (> depth 0) (str cur-item c) cur-item)
|
|
depth)))
|
|
(else (go (+ i 1) acc (str cur-item c) depth)))))))
|
|
(go 0 (list) "" 0)))
|
|
|
|
(define
|
|
tcl-eval-words
|
|
(fn
|
|
(words interp)
|
|
(reduce
|
|
(fn
|
|
(acc w)
|
|
(let
|
|
((cur-interp (get acc :interp)))
|
|
(if
|
|
(equal? (get w :type) "expand")
|
|
(let
|
|
((wr (tcl-eval-word (get w :word) cur-interp)))
|
|
{:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
|
|
(let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
|
|
{:values (quote ()) :interp interp}
|
|
words)))
|
|
|
|
(define
|
|
tcl-eval-cmd
|
|
(fn
|
|
(interp cmd)
|
|
(let
|
|
((wr (tcl-eval-words (get cmd :words) interp)))
|
|
(let
|
|
((words (get wr :values)) (cur-interp (get wr :interp)))
|
|
(if
|
|
(= 0 (len words))
|
|
cur-interp
|
|
(let
|
|
((cmd-name (first words)) (cmd-args (rest words)))
|
|
(let
|
|
((cmd-fn (get (get cur-interp :commands) cmd-name)))
|
|
(if
|
|
(nil? cmd-fn)
|
|
(error (str "unknown command: \"" cmd-name "\""))
|
|
(cmd-fn cur-interp cmd-args)))))))))
|
|
|
|
(define
|
|
tcl-eval-script
|
|
(fn
|
|
(interp cmds)
|
|
(if
|
|
(or (= 0 (len cmds)) (not (= 0 (get interp :code))))
|
|
interp
|
|
(tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))
|
|
|
|
(define
|
|
tcl-eval-string
|
|
(fn (interp src) (tcl-eval-script interp (tcl-parse src))))
|
|
|
|
(define
|
|
tcl-cmd-set
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= (len args) 1)
|
|
(assoc interp :result (tcl-var-get interp (first args)))
|
|
(let
|
|
((val (nth args 1)))
|
|
(assoc (tcl-var-set interp (first args) val) :result val)))))
|
|
|
|
(define
|
|
tcl-cmd-puts
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((text (last args))
|
|
(no-nl
|
|
(and
|
|
(> (len args) 1)
|
|
(equal? (first args) "-nonewline"))))
|
|
(let
|
|
((line (if no-nl text (str text "\n"))))
|
|
(assoc interp :output (str (get interp :output) line))))))
|
|
|
|
(define
|
|
tcl-cmd-incr
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args))
|
|
(delta
|
|
(if
|
|
(> (len args) 1)
|
|
(parse-int (nth args 1))
|
|
1)))
|
|
(let
|
|
((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
|
|
(assoc (tcl-var-set interp name new-val) :result new-val)))))
|
|
|
|
(define
|
|
tcl-cmd-append
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args)) (suffix (join "" (rest args))))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
|
|
(let
|
|
((new-val (str cur suffix)))
|
|
(assoc (tcl-var-set interp name new-val) :result new-val))))))
|
|
|
|
(define
|
|
tcl-true?
|
|
(fn
|
|
(s)
|
|
(not
|
|
(or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no")))))
|
|
|
|
(define tcl-false? (fn (s) (not (tcl-true? s))))
|
|
|
|
(define
|
|
tcl-expr-compute
|
|
(fn
|
|
(tokens)
|
|
(let
|
|
((n (len tokens)))
|
|
(cond
|
|
((= n 1) (first tokens))
|
|
((= n 2)
|
|
(let
|
|
((op (first tokens)) (x (nth tokens 1)))
|
|
(if
|
|
(equal? op "!")
|
|
(if (tcl-false? x) "1" "0")
|
|
(error (str "expr: unknown unary op: " op)))))
|
|
((= n 3)
|
|
(let
|
|
((l (first tokens)) (op (nth tokens 1)) (r (nth tokens 2)))
|
|
(cond
|
|
((equal? op "+") (str (+ (parse-int l) (parse-int r))))
|
|
((equal? op "-") (str (- (parse-int l) (parse-int r))))
|
|
((equal? op "*") (str (* (parse-int l) (parse-int r))))
|
|
((equal? op "/") (str (/ (parse-int l) (parse-int r))))
|
|
((equal? op "%") (str (mod (parse-int l) (parse-int r))))
|
|
((equal? op "==") (if (equal? l r) "1" "0"))
|
|
((equal? op "!=") (if (equal? l r) "0" "1"))
|
|
((equal? op "<")
|
|
(if (< (parse-int l) (parse-int r)) "1" "0"))
|
|
((equal? op ">")
|
|
(if (> (parse-int l) (parse-int r)) "1" "0"))
|
|
((equal? op "<=")
|
|
(if (<= (parse-int l) (parse-int r)) "1" "0"))
|
|
((equal? op ">=")
|
|
(if (>= (parse-int l) (parse-int r)) "1" "0"))
|
|
((equal? op "&&")
|
|
(if (and (tcl-true? l) (tcl-true? r)) "1" "0"))
|
|
((equal? op "||")
|
|
(if (or (tcl-true? l) (tcl-true? r)) "1" "0"))
|
|
(else (error (str "expr: unknown op: " op))))))
|
|
(else (error (str "expr: complex expr not yet supported")))))))
|
|
|
|
(define
|
|
tcl-expr-eval
|
|
(fn
|
|
(interp s)
|
|
(let
|
|
((cmds (tcl-parse s)))
|
|
(if
|
|
(= 0 (len cmds))
|
|
{:result "0" :interp interp}
|
|
(let
|
|
((wr (tcl-eval-words (get (first cmds) :words) interp)))
|
|
{:result (tcl-expr-compute (get wr :values)) :interp (get wr :interp)})))))
|
|
|
|
(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))
|
|
|
|
(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))
|
|
|
|
(define
|
|
tcl-cmd-return
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((val (if (> (len args) 0) (last args) "")))
|
|
(assoc (assoc interp :result val) :code 2))))
|
|
|
|
(define
|
|
tcl-cmd-error
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((msg (if (> (len args) 0) (first args) "error")))
|
|
(assoc (assoc interp :result msg) :code 1))))
|
|
|
|
(define
|
|
tcl-cmd-unset
|
|
(fn
|
|
(interp args)
|
|
(reduce
|
|
(fn
|
|
(i name)
|
|
(let
|
|
((frame (get i :frame)))
|
|
(let
|
|
((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals)))))
|
|
(assoc i :frame (assoc frame :locals new-locals)))))
|
|
interp
|
|
args)))
|
|
|
|
(define
|
|
tcl-cmd-lappend
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args)) (items (rest args)))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
|
|
(let
|
|
((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items)))))
|
|
(assoc (tcl-var-set interp name new-val) :result new-val))))))
|
|
|
|
(define
|
|
tcl-cmd-eval
|
|
(fn (interp args) (tcl-eval-string interp (join " " args))))
|
|
|
|
(define
|
|
tcl-while-loop
|
|
(fn
|
|
(interp cond-str body)
|
|
(let
|
|
((er (tcl-expr-eval interp cond-str)))
|
|
(if
|
|
(tcl-false? (get er :result))
|
|
(get er :interp)
|
|
(let
|
|
((body-result (tcl-eval-string (get er :interp) body)))
|
|
(let
|
|
((code (get body-result :code)))
|
|
(cond
|
|
((= code 3) (assoc body-result :code 0))
|
|
((= code 2) body-result)
|
|
((= code 1) body-result)
|
|
(else
|
|
(tcl-while-loop
|
|
(assoc body-result :code 0)
|
|
cond-str
|
|
body)))))))))
|
|
|
|
(define
|
|
tcl-cmd-while
|
|
(fn
|
|
(interp args)
|
|
(tcl-while-loop interp (first args) (nth args 1))))
|
|
|
|
(define
|
|
tcl-cmd-if
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((er (tcl-expr-eval interp (first args))))
|
|
(let
|
|
((cond-true (tcl-true? (get er :result)))
|
|
(new-interp (get er :interp))
|
|
(rest-args (rest args)))
|
|
(let
|
|
((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args)))
|
|
(let
|
|
((then-body (first adj)) (rest2 (rest adj)))
|
|
(if
|
|
cond-true
|
|
(tcl-eval-string new-interp then-body)
|
|
(cond
|
|
((= 0 (len rest2)) new-interp)
|
|
((equal? (first rest2) "else")
|
|
(if
|
|
(> (len rest2) 1)
|
|
(tcl-eval-string new-interp (nth rest2 1))
|
|
new-interp))
|
|
((equal? (first rest2) "elseif")
|
|
(tcl-cmd-if new-interp (rest rest2)))
|
|
(else new-interp)))))))))
|
|
|
|
(define
|
|
tcl-for-loop
|
|
(fn
|
|
(interp cond-str step body)
|
|
(let
|
|
((er (tcl-expr-eval interp cond-str)))
|
|
(if
|
|
(tcl-false? (get er :result))
|
|
(get er :interp)
|
|
(let
|
|
((body-result (tcl-eval-string (get er :interp) body)))
|
|
(let
|
|
((code (get body-result :code)))
|
|
(cond
|
|
((= code 3) (assoc body-result :code 0))
|
|
((= code 2) body-result)
|
|
((= code 1) body-result)
|
|
(else
|
|
(let
|
|
((step-result (tcl-eval-string (assoc body-result :code 0) step)))
|
|
(tcl-for-loop
|
|
(assoc step-result :code 0)
|
|
cond-str
|
|
step
|
|
body))))))))))
|
|
|
|
(define
|
|
tcl-cmd-for
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((init-body (first args))
|
|
(cond-str (nth args 1))
|
|
(step (nth args 2))
|
|
(body (nth args 3)))
|
|
(let
|
|
((init-result (tcl-eval-string interp init-body)))
|
|
(tcl-for-loop init-result cond-str step body)))))
|
|
|
|
(define
|
|
tcl-foreach-loop
|
|
(fn
|
|
(interp var-name items body)
|
|
(if
|
|
(= 0 (len items))
|
|
interp
|
|
(let
|
|
((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body)))
|
|
(let
|
|
((code (get body-result :code)))
|
|
(cond
|
|
((= code 3) (assoc body-result :code 0))
|
|
((= code 2) body-result)
|
|
((= code 1) body-result)
|
|
(else
|
|
(tcl-foreach-loop
|
|
(assoc body-result :code 0)
|
|
var-name
|
|
(rest items)
|
|
body))))))))
|
|
|
|
(define
|
|
tcl-cmd-foreach
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((var-name (first args))
|
|
(list-str (nth args 1))
|
|
(body (nth args 2)))
|
|
(tcl-foreach-loop interp var-name (tcl-list-split list-str) body))))
|
|
|
|
(define
|
|
tcl-cmd-switch
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((str-val (first args)) (body (nth args 1)))
|
|
(let
|
|
((pairs (tcl-list-split body)))
|
|
(define
|
|
try-pairs
|
|
(fn
|
|
(ps)
|
|
(if
|
|
(= 0 (len ps))
|
|
interp
|
|
(let
|
|
((pat (first ps)) (bdy (nth ps 1)))
|
|
(if
|
|
(or (equal? pat str-val) (equal? pat "default"))
|
|
(if
|
|
(equal? bdy "-")
|
|
(try-pairs (rest (rest ps)))
|
|
(tcl-eval-string interp bdy))
|
|
(try-pairs (rest (rest ps))))))))
|
|
(try-pairs pairs)))))
|
|
|
|
(define
|
|
tcl-cmd-expr
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((s (join " " args)))
|
|
(let
|
|
((er (tcl-expr-eval interp s)))
|
|
(assoc (get er :interp) :result (get er :result))))))
|
|
|
|
(define tcl-cmd-gets (fn (interp args) (assoc interp :result "")))
|
|
|
|
(define
|
|
tcl-cmd-subst
|
|
(fn (interp args) (assoc interp :result (last args))))
|
|
|
|
(define
|
|
tcl-cmd-format
|
|
(fn (interp args) (assoc interp :result (join "" args))))
|
|
|
|
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
|
|
|
|
(define
|
|
make-default-tcl-interp
|
|
(fn
|
|
()
|
|
(let
|
|
((i (make-tcl-interp)))
|
|
(let
|
|
((i (tcl-register i "set" tcl-cmd-set)))
|
|
(let
|
|
((i (tcl-register i "puts" tcl-cmd-puts)))
|
|
(let
|
|
((i (tcl-register i "incr" tcl-cmd-incr)))
|
|
(let
|
|
((i (tcl-register i "append" tcl-cmd-append)))
|
|
(let
|
|
((i (tcl-register i "unset" tcl-cmd-unset)))
|
|
(let
|
|
((i (tcl-register i "lappend" tcl-cmd-lappend)))
|
|
(let
|
|
((i (tcl-register i "eval" tcl-cmd-eval)))
|
|
(let
|
|
((i (tcl-register i "if" tcl-cmd-if)))
|
|
(let
|
|
((i (tcl-register i "while" tcl-cmd-while)))
|
|
(let
|
|
((i (tcl-register i "for" tcl-cmd-for)))
|
|
(let
|
|
((i (tcl-register i "foreach" tcl-cmd-foreach)))
|
|
(let
|
|
((i (tcl-register i "switch" tcl-cmd-switch)))
|
|
(let
|
|
((i (tcl-register i "break" tcl-cmd-break)))
|
|
(let
|
|
((i (tcl-register i "continue" tcl-cmd-continue)))
|
|
(let
|
|
((i (tcl-register i "return" tcl-cmd-return)))
|
|
(let
|
|
((i (tcl-register i "error" tcl-cmd-error)))
|
|
(let
|
|
((i (tcl-register i "expr" tcl-cmd-expr)))
|
|
(let
|
|
((i (tcl-register i "gets" tcl-cmd-gets)))
|
|
(let
|
|
((i (tcl-register i "subst" tcl-cmd-subst)))
|
|
(let
|
|
((i (tcl-register i "format" tcl-cmd-format)))
|
|
(tcl-register
|
|
i
|
|
"scan"
|
|
tcl-cmd-scan))))))))))))))))))))))))
|