280 lines
8.6 KiB
Plaintext
280 lines
8.6 KiB
Plaintext
;; lib/tcl/runtime.sx — Tcl primitives on SX
|
|
;;
|
|
;; Provides Tcl-idiomatic wrappers over SX built-ins.
|
|
;; Primitives used:
|
|
;; make-regexp/regexp-match/regexp-match-all/... (Phase 19)
|
|
;; make-set/set-add!/set-member?/set-remove!/set->list (Phase 18)
|
|
;; call/cc (core evaluator)
|
|
;; quotient/remainder (Phase 15 / builtin)
|
|
;; string->list/list->string/char->integer (Phase 13)
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 1. String buffer — Tcl append / string accumulation
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define
|
|
(tcl-sb-new)
|
|
(let
|
|
((sb (dict)))
|
|
(dict-set! sb "_tcl_sb" true)
|
|
(dict-set! sb "_buf" "")
|
|
sb))
|
|
|
|
(define (tcl-sb? v) (and (dict? v) (dict-has? v "_tcl_sb")))
|
|
|
|
(define
|
|
(tcl-sb-append! sb s)
|
|
(dict-set! sb "_buf" (str (get sb "_buf") s))
|
|
sb)
|
|
|
|
(define (tcl-sb-value sb) (get sb "_buf"))
|
|
|
|
(define (tcl-sb-clear! sb) (dict-set! sb "_buf" "") sb)
|
|
|
|
(define (tcl-sb-length sb) (len (get sb "_buf")))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 2. String port (channel) — Tcl channel abstraction
|
|
;; Read channel: created from a string, supports gets/read.
|
|
;; Write channel: accumulates puts output, queryable via tcl-chan-string.
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define
|
|
(tcl-chan-in-new str)
|
|
(let
|
|
((c (dict)))
|
|
(dict-set! c "_tcl_chan" true)
|
|
(dict-set! c "_mode" "read")
|
|
(dict-set! c "_chars" (string->list str))
|
|
(dict-set! c "_pos" 0)
|
|
c))
|
|
|
|
(define
|
|
(tcl-chan-out-new)
|
|
(let
|
|
((c (dict)))
|
|
(dict-set! c "_tcl_chan" true)
|
|
(dict-set! c "_mode" "write")
|
|
(dict-set! c "_buf" "")
|
|
c))
|
|
|
|
(define (tcl-chan? v) (and (dict? v) (dict-has? v "_tcl_chan")))
|
|
|
|
(define
|
|
(tcl-chan-eof? c)
|
|
(and
|
|
(= (get c "_mode") "read")
|
|
(>= (get c "_pos") (len (get c "_chars")))))
|
|
|
|
(define
|
|
(tcl-chan-read-char c)
|
|
(if
|
|
(tcl-chan-eof? c)
|
|
nil
|
|
(let
|
|
((ch (nth (get c "_chars") (get c "_pos"))))
|
|
(dict-set! c "_pos" (+ (get c "_pos") 1))
|
|
ch)))
|
|
|
|
;; gets — read one line (up to newline or EOF), return without trailing newline
|
|
(define
|
|
(tcl-chan-gets c)
|
|
(letrec
|
|
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (cond ((= ch nil) (list->string (reverse acc))) ((= (char->integer ch) 10) (list->string (reverse acc))) (else (go (cons ch acc))))))))
|
|
(go (list))))
|
|
|
|
;; read — read all remaining chars
|
|
(define
|
|
(tcl-chan-read c)
|
|
(letrec
|
|
((go (fn (acc) (let ((ch (tcl-chan-read-char c))) (if (= ch nil) (list->string (reverse acc)) (go (cons ch acc)))))))
|
|
(go (list))))
|
|
|
|
;; puts — write string to write channel (no newline)
|
|
(define
|
|
(tcl-chan-puts! c s)
|
|
(when
|
|
(= (get c "_mode") "write")
|
|
(dict-set! c "_buf" (str (get c "_buf") s)))
|
|
c)
|
|
|
|
;; puts-line — write string + newline (Tcl default puts behaviour)
|
|
(define (tcl-chan-puts-line! c s) (tcl-chan-puts! c (str s "\n")))
|
|
|
|
;; string — get accumulated content of write channel
|
|
(define (tcl-chan-string c) (get c "_buf"))
|
|
|
|
;; tell — current read position
|
|
(define (tcl-chan-tell c) (get c "_pos"))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 3. Regexp — Tcl regexp / regsub wrappers
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define (tcl-re-new pattern) (make-regexp pattern ""))
|
|
|
|
(define (tcl-re-new-flags pattern flags) (make-regexp pattern flags))
|
|
|
|
(define (tcl-re? v) (regexp? v))
|
|
|
|
(define (tcl-re-match? rx str) (not (= (regexp-match rx str) nil)))
|
|
|
|
(define (tcl-re-match rx str) (regexp-match rx str))
|
|
|
|
(define (tcl-re-match-all rx str) (regexp-match-all rx str))
|
|
|
|
(define (tcl-re-sub rx str replacement) (regexp-replace rx str replacement))
|
|
|
|
(define
|
|
(tcl-re-sub-all rx str replacement)
|
|
(regexp-replace-all rx str replacement))
|
|
|
|
(define (tcl-re-split rx str) (regexp-split rx str))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 4. Format — Tcl format command (%s %d %f %x %o %%)
|
|
;; tcl-format takes a format string and a list of arguments.
|
|
;; Example: (tcl-format "%s is %d" (list "Alice" 30)) → "Alice is 30"
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
;; Digit characters for base conversion
|
|
(define tcl-hex-chars (string->list "0123456789abcdef"))
|
|
|
|
(define
|
|
(tcl-digits-for-base n base digit-chars)
|
|
(let
|
|
((abs-n (if (< n 0) (- 0 n) n)))
|
|
(letrec
|
|
((go (fn (n acc) (if (= n 0) (if (= (len acc) 0) "0" (list->string acc)) (go (quotient n base) (cons (nth digit-chars (remainder n base)) acc))))))
|
|
(let
|
|
((unsigned (go abs-n (list))))
|
|
(if (< n 0) (str "-" unsigned) unsigned)))))
|
|
|
|
(define
|
|
(tcl-format-hex n)
|
|
(tcl-digits-for-base (truncate n) 16 tcl-hex-chars))
|
|
|
|
(define
|
|
(tcl-format-oct n)
|
|
(tcl-digits-for-base (truncate n) 8 (string->list "01234567")))
|
|
|
|
(define
|
|
(tcl-format fmt args)
|
|
(letrec
|
|
((chars (string->list fmt))
|
|
(go
|
|
(fn
|
|
(cs arg-list result)
|
|
(if
|
|
(= (len cs) 0)
|
|
result
|
|
(let
|
|
((c-int (char->integer (first cs))))
|
|
(if
|
|
(= c-int 37)
|
|
(if
|
|
(= (len (rest cs)) 0)
|
|
result
|
|
(let
|
|
((spec-int (char->integer (first (rest cs)))))
|
|
(cond
|
|
((= spec-int 37)
|
|
(go (rest (rest cs)) arg-list (str result "%")))
|
|
((= spec-int 115)
|
|
(go
|
|
(rest (rest cs))
|
|
(rest arg-list)
|
|
(str result (str (first arg-list)))))
|
|
((= spec-int 100)
|
|
(go
|
|
(rest (rest cs))
|
|
(rest arg-list)
|
|
(str result (str (truncate (first arg-list))))))
|
|
((= spec-int 102)
|
|
(go
|
|
(rest (rest cs))
|
|
(rest arg-list)
|
|
(str result (str (+ 0 (first arg-list))))))
|
|
((= spec-int 120)
|
|
(go
|
|
(rest (rest cs))
|
|
(rest arg-list)
|
|
(str result (tcl-format-hex (first arg-list)))))
|
|
((= spec-int 111)
|
|
(go
|
|
(rest (rest cs))
|
|
(rest arg-list)
|
|
(str result (tcl-format-oct (first arg-list)))))
|
|
(else
|
|
(go
|
|
(rest (rest cs))
|
|
arg-list
|
|
(str
|
|
result
|
|
"%"
|
|
(list->string (list (first (rest cs))))))))))
|
|
(go
|
|
(rest cs)
|
|
arg-list
|
|
(str result (list->string (list (first cs)))))))))))
|
|
(go chars args "")))
|
|
|
|
;; ---------------------------------------------------------------------------
|
|
;; 5. Coroutine — Tcl-style coroutine using call/cc
|
|
;; tcl-co-yield works reliably when called from top-level fns.
|
|
;; Avoid calling tcl-co-yield from letrec-bound lambdas (JIT limitation).
|
|
;; ---------------------------------------------------------------------------
|
|
|
|
(define tcl-current-co nil)
|
|
|
|
(define
|
|
(tcl-co-new body)
|
|
(let
|
|
((co (dict)))
|
|
(dict-set! co "_tcl_co" true)
|
|
(dict-set! co "_state" "new")
|
|
(dict-set! co "_cont" nil)
|
|
(dict-set! co "_resumer" nil)
|
|
(dict-set! co "_parent" nil)
|
|
(dict-set!
|
|
co
|
|
"_body"
|
|
(fn
|
|
()
|
|
(let
|
|
((result (body)))
|
|
(dict-set! co "_state" "dead")
|
|
(set! tcl-current-co (get co "_parent"))
|
|
((get co "_resumer") result))))
|
|
co))
|
|
|
|
(define (tcl-co? v) (and (dict? v) (dict-has? v "_tcl_co")))
|
|
|
|
(define (tcl-co-alive? co) (not (= (get co "_state") "dead")))
|
|
|
|
(define
|
|
(tcl-co-yield val)
|
|
(call/cc
|
|
(fn
|
|
(resume-k)
|
|
(let
|
|
((cur tcl-current-co))
|
|
(dict-set! cur "_cont" resume-k)
|
|
(dict-set! cur "_state" "suspended")
|
|
(set! tcl-current-co (get cur "_parent"))
|
|
((get cur "_resumer") val)))))
|
|
|
|
(define
|
|
(tcl-co-resume co)
|
|
(call/cc
|
|
(fn
|
|
(return-k)
|
|
(dict-set! co "_parent" tcl-current-co)
|
|
(dict-set! co "_resumer" return-k)
|
|
(set! tcl-current-co co)
|
|
(dict-set! co "_state" "running")
|
|
(if
|
|
(= (get co "_cont") nil)
|
|
((get co "_body"))
|
|
((get co "_cont") nil)))))
|