build: convert raw-Chez .sls library source to src/ .ss with generated .sls wrappers
ober
b2a5c3b18e89c136946b65ab6cc8d0f2f8454616
--- a/.gitignore +++ b/.gitignore @@ -20,3 +20,6 @@ /jawk_program.h .jawk-test-out .claude/ + +# Generated .sls wrappers from src/ .ss source +lib/**/*.sls --- a/Makefile +++ b/Makefile @@ -24,8 +24,12 @@ TARGET_EVIDENCE_DIR ?= dist/target-evidence all: binary +# Generate R6RS .sls wrappers from src/ .ss source. +transpile: + python3 support/wrap-ss-to-sls.py src lib + # Standalone native binary via .jerbuild (entry bin/jawk-program.ss -> jawk). -binary: +binary: transpile $(JERBUILD) build build: binary deleted file mode 100644 --- a/lib/jerboa-awk/ast.sls +++ /dev/null @@ -1,206 +0,0 @@ -#!chezscheme -;;;; AWK AST node definitions - -(library (jerboa-awk ast) - (export - ;; Program - awk-program make-awk-program awk-program? - awk-program-rules awk-program-functions - ;; Rules - awk-rule make-awk-rule awk-rule? - awk-rule-pattern awk-rule-action - ;; Patterns - awk-pattern-begin make-awk-pattern-begin awk-pattern-begin? - awk-pattern-end make-awk-pattern-end awk-pattern-end? - awk-pattern-expr make-awk-pattern-expr awk-pattern-expr? - awk-pattern-expr-expr - awk-pattern-range make-awk-pattern-range awk-pattern-range? - awk-pattern-range-start awk-pattern-range-end - ;; Statements - awk-stmt-block make-awk-stmt-block awk-stmt-block? - awk-stmt-block-stmts - awk-stmt-if make-awk-stmt-if awk-stmt-if? - awk-stmt-if-condition awk-stmt-if-then-branch awk-stmt-if-else-branch - awk-stmt-while make-awk-stmt-while awk-stmt-while? - awk-stmt-while-condition awk-stmt-while-body - awk-stmt-do-while make-awk-stmt-do-while awk-stmt-do-while? - awk-stmt-do-while-body awk-stmt-do-while-condition - awk-stmt-for make-awk-stmt-for awk-stmt-for? - awk-stmt-for-init awk-stmt-for-condition awk-stmt-for-update awk-stmt-for-body - awk-stmt-for-in make-awk-stmt-for-in awk-stmt-for-in? - awk-stmt-for-in-var awk-stmt-for-in-array awk-stmt-for-in-body - awk-stmt-break make-awk-stmt-break awk-stmt-break? - awk-stmt-continue make-awk-stmt-continue awk-stmt-continue? - awk-stmt-next make-awk-stmt-next awk-stmt-next? - awk-stmt-nextfile make-awk-stmt-nextfile awk-stmt-nextfile? - awk-stmt-exit make-awk-stmt-exit awk-stmt-exit? - awk-stmt-exit-code - awk-stmt-return make-awk-stmt-return awk-stmt-return? - awk-stmt-return-value - awk-stmt-delete make-awk-stmt-delete awk-stmt-delete? - awk-stmt-delete-target - awk-stmt-print make-awk-stmt-print awk-stmt-print? - awk-stmt-print-args awk-stmt-print-redirect - awk-stmt-printf make-awk-stmt-printf awk-stmt-printf? - awk-stmt-printf-format awk-stmt-printf-args awk-stmt-printf-redirect - awk-stmt-expr make-awk-stmt-expr awk-stmt-expr? - awk-stmt-expr-expr - ;; Expressions - awk-expr-number make-awk-expr-number awk-expr-number? - awk-expr-number-value - awk-expr-string make-awk-expr-string awk-expr-string? - awk-expr-string-value - awk-expr-regex make-awk-expr-regex awk-expr-regex? - awk-expr-regex-pattern - awk-expr-var make-awk-expr-var awk-expr-var? - awk-expr-var-name - awk-expr-field make-awk-expr-field awk-expr-field? - awk-expr-field-index - awk-expr-array-ref make-awk-expr-array-ref awk-expr-array-ref? - awk-expr-array-ref-name awk-expr-array-ref-subscripts - awk-expr-binop make-awk-expr-binop awk-expr-binop? - awk-expr-binop-op awk-expr-binop-left awk-expr-binop-right - awk-expr-unop make-awk-expr-unop awk-expr-unop? - awk-expr-unop-op awk-expr-unop-operand - awk-expr-assign make-awk-expr-assign awk-expr-assign? - awk-expr-assign-target awk-expr-assign-value - awk-expr-assign-op make-awk-expr-assign-op awk-expr-assign-op? - awk-expr-assign-op-op awk-expr-assign-op-target awk-expr-assign-op-value - awk-expr-pre-inc make-awk-expr-pre-inc awk-expr-pre-inc? - awk-expr-pre-inc-target - awk-expr-pre-dec make-awk-expr-pre-dec awk-expr-pre-dec? - awk-expr-pre-dec-target - awk-expr-post-inc make-awk-expr-post-inc awk-expr-post-inc? - awk-expr-post-inc-target - awk-expr-post-dec make-awk-expr-post-dec awk-expr-post-dec? - awk-expr-post-dec-target - awk-expr-ternary make-awk-expr-ternary awk-expr-ternary? - awk-expr-ternary-condition awk-expr-ternary-then-expr awk-expr-ternary-else-expr - awk-expr-concat make-awk-expr-concat awk-expr-concat? - awk-expr-concat-left awk-expr-concat-right - awk-expr-in make-awk-expr-in awk-expr-in? - awk-expr-in-subscripts awk-expr-in-array - awk-expr-match make-awk-expr-match awk-expr-match? - awk-expr-match-expr awk-expr-match-pattern awk-expr-match-negate? - awk-expr-call make-awk-expr-call awk-expr-call? - awk-expr-call-name awk-expr-call-args - awk-expr-getline make-awk-expr-getline awk-expr-getline? - awk-expr-getline-var awk-expr-getline-source awk-expr-getline-command? - ;; I/O Redirection - awk-redirect make-awk-redirect awk-redirect? - awk-redirect-type awk-redirect-target - ;; Function definition - awk-func make-awk-func awk-func? - awk-func-name awk-func-params awk-func-body) - - (import (scheme) - (std match2)) - - ;;; Program structure - (define-record-type awk-program (fields rules functions)) - (define-record-type awk-rule (fields pattern action)) - - ;;; Pattern types - (define-record-type awk-pattern-begin) - (define-record-type awk-pattern-end) - (define-record-type awk-pattern-expr (fields expr)) - (define-record-type awk-pattern-range (fields start end)) - - ;;; Statements - (define-record-type awk-stmt-block (fields stmts)) - (define-record-type awk-stmt-if (fields condition then-branch else-branch)) - (define-record-type awk-stmt-while (fields condition body)) - (define-record-type awk-stmt-do-while (fields body condition)) - (define-record-type awk-stmt-for (fields init condition update body)) - (define-record-type awk-stmt-for-in (fields var array body)) - (define-record-type awk-stmt-break) - (define-record-type awk-stmt-continue) - (define-record-type awk-stmt-next) - (define-record-type awk-stmt-nextfile) - (define-record-type awk-stmt-exit (fields code)) - (define-record-type awk-stmt-return (fields value)) - (define-record-type awk-stmt-delete (fields target)) - (define-record-type awk-stmt-print (fields args redirect)) - (define-record-type awk-stmt-printf (fields format args redirect)) - (define-record-type awk-stmt-expr (fields expr)) - - ;;; Expressions - (define-record-type awk-expr-number (fields value)) - (define-record-type awk-expr-string (fields value)) - (define-record-type awk-expr-regex (fields pattern)) - (define-record-type awk-expr-var (fields name)) - (define-record-type awk-expr-field (fields index)) - (define-record-type awk-expr-array-ref (fields name subscripts)) - (define-record-type awk-expr-binop (fields op left right)) - (define-record-type awk-expr-unop (fields op operand)) - (define-record-type awk-expr-assign (fields target value)) - (define-record-type awk-expr-assign-op (fields op target value)) - (define-record-type awk-expr-pre-inc (fields target)) - (define-record-type awk-expr-pre-dec (fields target)) - (define-record-type awk-expr-post-inc (fields target)) - (define-record-type awk-expr-post-dec (fields target)) - (define-record-type awk-expr-ternary (fields condition then-expr else-expr)) - (define-record-type awk-expr-concat (fields left right)) - (define-record-type awk-expr-in (fields subscripts array)) - (define-record-type awk-expr-match (fields expr pattern negate?)) - (define-record-type awk-expr-call (fields name args)) - (define-record-type awk-expr-getline (fields var source command?)) - - ;;; I/O Redirection - (define-record-type awk-redirect (fields type target)) - - ;;; Function definition - (define-record-type awk-func (fields name params body)) - - ;;; Register all types for (std match2) pattern matching - ;; Program - (define-match-type awk-program awk-program? awk-program-rules awk-program-functions) - (define-match-type awk-rule awk-rule? awk-rule-pattern awk-rule-action) - ;; Patterns - (define-match-type awk-pattern-begin awk-pattern-begin?) - (define-match-type awk-pattern-end awk-pattern-end?) - (define-match-type awk-pattern-expr awk-pattern-expr? awk-pattern-expr-expr) - (define-match-type awk-pattern-range awk-pattern-range? awk-pattern-range-start awk-pattern-range-end) - ;; Statements - (define-match-type awk-stmt-block awk-stmt-block? awk-stmt-block-stmts) - (define-match-type awk-stmt-if awk-stmt-if? awk-stmt-if-condition awk-stmt-if-then-branch awk-stmt-if-else-branch) - (define-match-type awk-stmt-while awk-stmt-while? awk-stmt-while-condition awk-stmt-while-body) - (define-match-type awk-stmt-do-while awk-stmt-do-while? awk-stmt-do-while-body awk-stmt-do-while-condition) - (define-match-type awk-stmt-for awk-stmt-for? awk-stmt-for-init awk-stmt-for-condition awk-stmt-for-update awk-stmt-for-body) - (define-match-type awk-stmt-for-in awk-stmt-for-in? awk-stmt-for-in-var awk-stmt-for-in-array awk-stmt-for-in-body) - (define-match-type awk-stmt-break awk-stmt-break?) - (define-match-type awk-stmt-continue awk-stmt-continue?) - (define-match-type awk-stmt-next awk-stmt-next?) - (define-match-type awk-stmt-nextfile awk-stmt-nextfile?) - (define-match-type awk-stmt-exit awk-stmt-exit? awk-stmt-exit-code) - (define-match-type awk-stmt-return awk-stmt-return? awk-stmt-return-value) - (define-match-type awk-stmt-delete awk-stmt-delete? awk-stmt-delete-target) - (define-match-type awk-stmt-print awk-stmt-print? awk-stmt-print-args awk-stmt-print-redirect) - (define-match-type awk-stmt-printf awk-stmt-printf? awk-stmt-printf-format awk-stmt-printf-args awk-stmt-printf-redirect) - (define-match-type awk-stmt-expr awk-stmt-expr? awk-stmt-expr-expr) - ;; Expressions - (define-match-type awk-expr-number awk-expr-number? awk-expr-number-value) - (define-match-type awk-expr-string awk-expr-string? awk-expr-string-value) - (define-match-type awk-expr-regex awk-expr-regex? awk-expr-regex-pattern) - (define-match-type awk-expr-var awk-expr-var? awk-expr-var-name) - (define-match-type awk-expr-field awk-expr-field? awk-expr-field-index) - (define-match-type awk-expr-array-ref awk-expr-array-ref? awk-expr-array-ref-name awk-expr-array-ref-subscripts) - (define-match-type awk-expr-binop awk-expr-binop? awk-expr-binop-op awk-expr-binop-left awk-expr-binop-right) - (define-match-type awk-expr-unop awk-expr-unop? awk-expr-unop-op awk-expr-unop-operand) - (define-match-type awk-expr-assign awk-expr-assign? awk-expr-assign-target awk-expr-assign-value) - (define-match-type awk-expr-assign-op awk-expr-assign-op? awk-expr-assign-op-op awk-expr-assign-op-target awk-expr-assign-op-value) - (define-match-type awk-expr-pre-inc awk-expr-pre-inc? awk-expr-pre-inc-target) - (define-match-type awk-expr-pre-dec awk-expr-pre-dec? awk-expr-pre-dec-target) - (define-match-type awk-expr-post-inc awk-expr-post-inc? awk-expr-post-inc-target) - (define-match-type awk-expr-post-dec awk-expr-post-dec? awk-expr-post-dec-target) - (define-match-type awk-expr-ternary awk-expr-ternary? awk-expr-ternary-condition awk-expr-ternary-then-expr awk-expr-ternary-else-expr) - (define-match-type awk-expr-concat awk-expr-concat? awk-expr-concat-left awk-expr-concat-right) - (define-match-type awk-expr-in awk-expr-in? awk-expr-in-subscripts awk-expr-in-array) - (define-match-type awk-expr-match awk-expr-match? awk-expr-match-expr awk-expr-match-pattern awk-expr-match-negate?) - (define-match-type awk-expr-call awk-expr-call? awk-expr-call-name awk-expr-call-args) - (define-match-type awk-expr-getline awk-expr-getline? awk-expr-getline-var awk-expr-getline-source awk-expr-getline-command?) - ;; I/O - (define-match-type awk-redirect awk-redirect? awk-redirect-type awk-redirect-target) - (define-match-type awk-func awk-func? awk-func-name awk-func-params awk-func-body) - -) ;; end library deleted file mode 100644 --- a/lib/jerboa-awk/builtins/io.sls +++ /dev/null @@ -1,44 +0,0 @@ -#!chezscheme -;;;; AWK I/O Built-in Functions - -(library (jerboa-awk builtins io) - (export - awk-builtin-close - awk-builtin-system - awk-builtin-fflush) - - (import (scheme) - (only (std security taint) check-untainted! safe-system) - (jerboa-awk value) - (jerboa-awk runtime) - (jerboa-awk ast)) - - ;;; close(file) - (define (awk-builtin-close env args) - (make-awk-number (env-close-file! env (awk->string (car args))))) - - ;;; system(command) - (define (awk-builtin-system env args) - (require-awk-shell-enabled! 'awk-builtin-system) - (let* ((cmd (awk->string (car args))) - (_ (check-untainted! cmd 'awk-builtin-system)) - (status (safe-system cmd))) - ;; system returns the exit status - (make-awk-number (if (integer? status) status -1)))) - - ;;; fflush([file]) - (define (awk-builtin-fflush env args) - (if (null? args) - (begin (flush-output-port (current-output-port)) - (make-awk-number 0)) - (let ((name (awk->string (car args)))) - (if (string=? name "") - (begin (flush-output-port (current-output-port)) - (make-awk-number 0)) - (cond - ((hash-key? (awk-env-output-files env) name) - (flush-output-port (hash-ref (awk-env-output-files env) name #f)) - (make-awk-number 0)) - (else (make-awk-number -1))))))) - -) ;; end library deleted file mode 100644 --- a/lib/jerboa-awk/builtins/math.sls +++ /dev/null @@ -1,81 +0,0 @@ -#!chezscheme -;;;; AWK Math Built-in Functions - -(library (jerboa-awk builtins math) - (export - awk-builtin-sin - awk-builtin-cos - awk-builtin-atan2 - awk-builtin-exp - awk-builtin-log - awk-builtin-sqrt - awk-builtin-int - awk-builtin-rand - awk-builtin-srand) - - (import (scheme) - (jerboa-awk value) - (jerboa-awk runtime) - (jerboa-awk ast)) - - (define (awk-builtin-sin env args) - (make-awk-number (sin (awk->number (car args))))) - - (define (awk-builtin-cos env args) - (make-awk-number (cos (awk->number (car args))))) - - (define (awk-builtin-atan2 env args) - (make-awk-number (atan (awk->number (car args)) - (awk->number (cadr args))))) - - (define (awk-builtin-exp env args) - (make-awk-number (exp (awk->number (car args))))) - - (define (awk-builtin-log env args) - (make-awk-number (log (awk->number (car args))))) - - (define (awk-builtin-sqrt env args) - (make-awk-number (sqrt (awk->number (car args))))) - - (define (awk-builtin-int env args) - (make-awk-number (truncate (awk->number (car args))))) - - ;;; rand() / srand() - ;; Chez Scheme doesn't have SRFI-27, so we use a simple LCG seeded PRNG - ;; that produces floats in [0, 1). - - (define (awk-rand-init! env) - (unless (awk-env-rand-initialized? env) - (awk-env-rand-state-set! env (awk-env-rand-seed env)) - (awk-env-rand-initialized?-set! env #t))) - - (define (awk-rand-next! env) - ;; LCG: same constants as glibc - (let ((next-state - (mod (+ (* 1103515245 (awk-env-rand-state env)) 12345) - (expt 2 31)))) - (awk-env-rand-state-set! env next-state) - (/ (inexact next-state) (inexact (expt 2 31))))) - - (define (awk-builtin-rand env args) - (env-assert-owner! 'awk-builtin-rand env) - (awk-rand-init! env) - (make-awk-number (awk-rand-next! env))) - - (define (awk-builtin-srand env args) - (env-assert-owner! 'awk-builtin-srand env) - (let ((old-seed (awk-env-rand-seed env))) - (if (null? args) - (let ((new-seed (time-second (current-time)))) - (awk-env-rand-seed-set! env new-seed) - (awk-env-rand-state-set! env new-seed) - (awk-env-rand-initialized?-set! env #t) - (make-awk-number old-seed)) - (let ((new-seed - (inexact->exact (floor (awk->number (car args)))))) - (awk-env-rand-seed-set! env new-seed) - (awk-env-rand-state-set! env new-seed) - (awk-env-rand-initialized?-set! env #t) - (make-awk-number old-seed))))) - -) ;; end library deleted file mode 100644 --- a/lib/jerboa-awk/builtins/string.sls +++ /dev/null @@ -1,441 +0,0 @@ -#!chezscheme -;;;; AWK String Built-in Functions - -(library (jerboa-awk builtins string) - (export - awk-builtin-length - awk-builtin-substr - awk-builtin-index - awk-builtin-split - awk-builtin-sub - awk-builtin-gsub - awk-builtin-match - awk-builtin-sprintf - awk-builtin-tolower - awk-builtin-toupper - awk-sprintf) - - (import (scheme) - (only (std misc string) string-contains string-trim) - (only (std os env) getenv) - (jerboa-awk value) - (jerboa-awk runtime) - (jerboa-awk ast) - (std pregexp)) - - (define max-format-width - (let ((v (getenv "JAWK_MAX_FORMAT_WIDTH"))) - (if v - (let ((n (string->number v))) - (if (and n (integer? n) (> n 0)) n 65536)) - 65536))) - - (define (check-format-bounds! who width prec) - (when (and width (> width max-format-width)) - (error who "printf width exceeds configured limit (JAWK_MAX_FORMAT_WIDTH)" width max-format-width)) - (when (and prec (> prec max-format-width)) - (error who "printf precision exceeds configured limit (JAWK_MAX_FORMAT_WIDTH)" prec max-format-width))) - - ;;; length([s]) - (define (awk-builtin-length env args) - (if (null? args) - (make-awk-number (string-length (awk->string (env-get-field env 0)))) - (let ((v (car args))) - (make-awk-number (string-length (awk->string v)))))) - - ;;; substr(s, start [, len]) - (define (awk-builtin-substr env args) - (let* ((str (awk->string (car args))) - (slen (string-length str)) - (pos (inexact->exact (floor (awk->number (cadr args))))) - (pos (max 1 pos)) - (maxlen (if (> (length args) 2) - (inexact->exact (floor (awk->number (caddr args)))) - (+ slen 1)))) - (if (> pos slen) - (make-awk-string "") - (let* ((start (- pos 1)) - (end (min (+ start maxlen) slen))) - (make-awk-string (substring str start end)))))) - - ;;; index(s, t) - (define (awk-builtin-index env args) - (let* ((str (awk->string (car args))) - (target (awk->string (cadr args))) - (pos (string-contains str target))) - (make-awk-number (if pos (+ pos 1) 0)))) - - ;;; split(s, a [, fs]) - (define (awk-builtin-split env args) - (let* ((str (awk->string (car args))) - (arr-name (cadr args)) ;; awk-expr-var passed by reference - (fs (if (> (length args) 2) - (awk->string (caddr args)) - (env-get-str env 'FS))) - (parts (cond - ((string=? fs " ") (split-on-whitespace str)) - ((string=? fs "") (map string (string->list str))) - ((= (string-length fs) 1) (split-on-char str (string-ref fs 0))) - (else (pregexp-split (env-regex env fs) str)))) - (arr (env-get-array env arr-name))) - ;; Clear array - (hash-clear! arr) - ;; Populate 1-indexed - (let loop ((i 1) (parts parts)) - (unless (null? parts) - (hash-put! arr (number->string i) (make-awk-strnum (car parts))) - (loop (+ i 1) (cdr parts)))) - (make-awk-number (length parts)))) - - ;;; sub(re, repl [, target]) -- returns count of replacements (0 or 1) - (define (awk-builtin-sub env args ere repl-str target-expr set-target!) - (let* ((pattern (if (awk-expr-regex? ere) - (awk-expr-regex-pattern ere) - (awk->string ere))) - (target-str (awk->string target-expr)) - (m (pregexp-match-positions (env-regex env pattern) target-str))) - (if m - (let* ((pos (car m)) ;; first element is the full match (start . end) - (start (car pos)) - (end (cdr pos)) - (replacement (build-replacement repl-str pos target-str)) - (result (string-append (substring target-str 0 start) - replacement - (substring target-str end (string-length target-str))))) - (set-target! (make-awk-string result)) - (make-awk-number 1)) - (make-awk-number 0)))) - - ;;; gsub(re, repl [, target]) -- returns count of replacements - (define (awk-builtin-gsub env args ere repl-str target-expr set-target!) - (let* ((pattern (if (awk-expr-regex? ere) - (awk-expr-regex-pattern ere) - (awk->string ere))) - (target-str (awk->string target-expr)) - (re (env-regex env pattern)) - (tlen (string-length target-str)) - (out (open-output-string)) - (count 0)) - ;; Compile the regex once and stream the gap/replacement pieces into an - ;; output port (O(n) assembly) instead of re-consing a piece list and - ;; apply-string-appending it at the end. - ;; - ;; Empty matches follow awk/gawk semantics so a pattern like /x*/ or /a*/ - ;; cannot loop forever: after a zero-length match the replacement is - ;; emitted and the next character is consumed literally, advancing the - ;; scan by one. A zero-length match sitting immediately after a non-empty - ;; match is suppressed (that character is passed through literally), which - ;; is what makes gsub(/a*/,"b","banana") yield "bbbnbnb" rather than - ;; inserting a separator after every 'a'. - (let loop ((pos 0) (prev-nonempty? #f)) - (cond - ((> pos tlen) - (set-target! (make-awk-string (get-output-string out))) - (make-awk-number count)) - (else - (let ((m (pregexp-match-positions re target-str pos))) - (if (not m) - (begin - (put-string out (substring target-str pos tlen)) - (set-target! (make-awk-string (get-output-string out))) - (make-awk-number count)) - (let* ((mpos (car m)) ;; full match (start . end) - (start (car mpos)) - (end (cdr mpos))) - (cond - ((and prev-nonempty? (= start end)) - (put-string out (substring target-str pos start)) - (when (< start tlen) - (put-string out (substring target-str start (+ start 1)))) - (loop (+ start 1) #f)) - (else - (let ((replacement (build-replacement repl-str mpos target-str))) - (set! count (+ count 1)) - (put-string out (substring target-str pos start)) - (put-string out replacement) - (if (= start end) - (begin - (when (< end tlen) - (put-string out (substring target-str end (+ end 1)))) - (loop (+ end 1) #f)) - (loop end #t))))))))))))) - - (define (build-replacement repl-str match-pair target-str) - "Process replacement string: & = matched text, \\ = literal backslash" - (let ((mstart (car match-pair)) - (mend (cdr match-pair)) - (rlen (string-length repl-str))) - (let loop ((i 0) (chars '())) - (if (>= i rlen) - (list->string (reverse chars)) - (let ((c (string-ref repl-str i))) - (cond - ((char=? c #\\) - (if (< (+ i 1) rlen) - (let ((next (string-ref repl-str (+ i 1)))) - (if (char=? next #\&) - (loop (+ i 2) (cons #\& chars)) - (if (char=? next #\\) - (loop (+ i 2) (cons #\\ chars)) - (loop (+ i 2) (cons next (cons #\\ chars)))))) - (loop (+ i 1) (cons #\\ chars)))) - ((char=? c #\&) - (let ((matched (substring target-str mstart mend))) - (loop (+ i 1) - (append (reverse (string->list matched)) chars)))) - (else - (loop (+ i 1) (cons c chars))))))))) - - ;;; match(s, re) - (define (awk-builtin-match env args) - (let* ((str (awk->string (car args))) - (pattern (let ((p (cadr args))) - (if (awk-expr-regex? p) - (awk-expr-regex-pattern p) - (awk->string p)))) - (m (pregexp-match-positions (env-regex env pattern) str))) - (if m - (let* ((pos (car m)) ;; full match (start . end) - (start (car pos)) - (end (cdr pos))) - (env-set! env 'RSTART (make-awk-number (+ start 1))) - (env-set! env 'RLENGTH (make-awk-number (- end start))) - (make-awk-number (+ start 1))) - (begin - (env-set! env 'RSTART (make-awk-number 0)) - (env-set! env 'RLENGTH (make-awk-number -1)) - (make-awk-number 0))))) - - ;;; sprintf(fmt, ...) - (define (awk-builtin-sprintf env args) - (let ((fmt (awk->string (car args))) - (vals (cdr args))) - (make-awk-string (awk-sprintf fmt vals)))) - - ;;; tolower(s) - (define (awk-builtin-tolower env args) - (make-awk-string (string-downcase (awk->string (car args))))) - - ;;; toupper(s) - (define (awk-builtin-toupper env args) - (make-awk-string (string-upcase (awk->string (car args))))) - - ;;; Printf/Sprintf formatting engine - - (define (awk-sprintf fmt args) - "Format string using AWK printf rules" - (let ((flen (string-length fmt))) - (let loop ((i 0) (args args) (out '())) - (if (>= i flen) - (list->string (reverse out)) - (let ((c (string-ref fmt i))) - (if (char=? c #\\) - ;; Escape sequence - (if (< (+ i 1) flen) - (let ((next (string-ref fmt (+ i 1)))) - (case next - ((#\n) (loop (+ i 2) args (cons #\newline out))) - ((#\t) (loop (+ i 2) args (cons #\tab out))) - ((#\r) (loop (+ i 2) args (cons #\return out))) - ((#\\) (loop (+ i 2) args (cons #\\ out))) - ((#\a) (loop (+ i 2) args (cons #\alarm out))) - ((#\b) (loop (+ i 2) args (cons #\backspace out))) - ((#\f) (loop (+ i 2) args (cons #\page out))) - ((#\v) (loop (+ i 2) args (cons #\vtab out))) - ((#\") (loop (+ i 2) args (cons #\" out))) - ((#\/) (loop (+ i 2) args (cons #\/ out))) - (else (loop (+ i 2) args (cons next out))))) - (loop (+ i 1) args (cons #\\ out))) - (if (char=? c #\%) - (if (and (< (+ i 1) flen) (char=? (string-ref fmt (+ i 1)) #\%)) - (loop (+ i 2) args (cons #\% out)) - (let-values (((formatted new-i new-args) (format-one-spec fmt i args))) - (loop new-i new-args - (append (reverse (string->list formatted)) out)))) - (loop (+ i 1) args (cons c out))))))))) - - (define (format-one-spec fmt start args) - "Parse and format one %... specifier" - (let ((flen (string-length fmt))) - (let loop ((i (+ start 1)) (flags "") (width #f) (prec #f) (state 'flags)) - (if (>= i flen) - (values "%" i args) - (let ((c (string-ref fmt i))) - (case state - ((flags) - (if (memq c '(#\- #\+ #\space #\0 #\#)) - (loop (+ i 1) (string-append flags (string c)) width prec 'flags) - (loop i flags width prec 'width))) - ((width) - (cond - ((char=? c #\*) - ;; Width from argument - (let ((w (inexact->exact (floor (awk->number (car args)))))) - (set! args (cdr args)) - (loop (+ i 1) flags w prec 'dot))) - ((char-numeric? c) - (let num-loop ((j i) (n 0)) - (if (and (< j flen) (char-numeric? (string-ref fmt j))) - (num-loop (+ j 1) (+ (* n 10) (- (char->integer (string-ref fmt j)) - (char->integer #\0)))) - (loop j flags n prec 'dot)))) - (else (loop i flags width prec 'dot)))) - ((dot) - (if (char=? c #\.) - (loop (+ i 1) flags width prec 'prec) - (loop i flags width prec 'spec))) - ((prec) - (cond - ((char=? c #\*) - (let ((p (inexact->exact (floor (awk->number (car args)))))) - (set! args (cdr args)) - (loop (+ i 1) flags width p 'spec))) - ((char-numeric? c) - (let num-loop ((j i) (n 0)) - (if (and (< j flen) (char-numeric? (string-ref fmt j))) - (num-loop (+ j 1) (+ (* n 10) (- (char->integer (string-ref fmt j)) - (char->integer #\0)))) - (loop j flags width n 'spec)))) - (else (loop i flags width (or prec 0) 'spec)))) - ((spec) - (check-format-bounds! 'awk-sprintf width prec) - (let ((arg (if (null? args) (make-awk-uninit) (car args))) - (rest (if (null? args) '() (cdr args)))) - (values (do-format c arg flags (or width 0) prec) - (+ i 1) rest))))))))) - - (define (do-format spec arg flags width prec) - (let ((left-align? (string-contains flags "-")) - (zero-pad? (string-contains flags "0")) - (plus? (string-contains flags "+")) - (space? (string-contains flags " "))) - (case spec - ((#\d #\i) - (let* ((n (inexact->exact (truncate (awk->number arg)))) - (s (number->string n)) - (s (if (and plus? (>= n 0)) (string-append "+" s) - (if (and space? (>= n 0)) (string-append " " s) s)))) - (pad-string s width left-align? (and zero-pad? (not left-align?))))) - ((#\o) - (let* ((n (inexact->exact (truncate (awk->number arg)))) - (n (if (< n 0) (+ n (expt 2 32)) n)) - (s (number->string n 8))) - (pad-string s width left-align? zero-pad?))) - ((#\x #\X) - (let* ((n (inexact->exact (truncate (awk->number arg)))) - (n (if (< n 0) (+ n (expt 2 32)) n)) - (s (number->string n 16)) - (s (if (char=? spec #\X) (string-upcase s) s))) - (pad-string s width left-align? zero-pad?))) - ((#\c) - (let* ((n (awk->number arg)) - (ch (if (and (not (zero? n)) (= n (floor n))) - ;; Numeric argument: treat as character code - (string (integer->char (inexact->exact (floor n)))) - ;; String argument: take first character - (let ((s (awk->string arg))) - (if (> (string-length s) 0) - (string (string-ref s 0)) - " "))))) - (pad-string ch width left-align? #f))) - ((#\s) - (let* ((s (awk->string arg)) - (s (if prec (substring s 0 (min prec (string-length s))) s))) - (pad-string s width left-align? #f))) - ((#\f) - (let* ((n (awk->number arg)) - (prec (or prec 6)) - (s (format-float-f n prec))) - (pad-string s width left-align? zero-pad?))) - ((#\e #\E) - (let* ((n (awk->number arg)) - (prec (or prec 6)) - (s (format-float-e n prec (char=? spec #\E)))) - (pad-string s width left-align? zero-pad?))) - ((#\g #\G) - (let* ((n (awk->number arg)) - (prec (or prec 6)) - (prec (max prec 1)) - (s (format-float-g n prec (char=? spec #\G)))) - (pad-string s width left-align? zero-pad?))) - (else (string spec))))) - - (define (pad-string s width left-align? zero-pad?) - (let ((pad (max 0 (- width (string-length s))))) - (if (= pad 0) s - (if left-align? - (string-append s (make-string pad #\space)) - (string-append (make-string pad (if zero-pad? #\0 #\space)) s))))) - - ;;; Float formatting - - (define (format-float-f n prec) - "Format float in %f style" - (if (= prec 0) - (number->string (inexact->exact (round n))) - (let* ((factor (expt 10 prec)) - (rounded (/ (round (* n factor)) factor)) - (int-part (inexact->exact (truncate rounded))) - (frac-part (abs (- rounded int-part))) - (frac-digits (inexact->exact (round (* frac-part factor)))) - (frac-str (number->string frac-digits)) - (frac-str (string-append (make-string (max 0 (- prec (string-length frac-str))) #\0) - frac-str)) - (sign (if (and (< n 0) (= int-part 0)) "-" ""))) - (string-append sign (number->string (abs int-part)) "." frac-str)))) - - (define (format-float-e n prec upper?) - "Format float in %e style" - (if (zero? n) - (string-append "0." (make-string prec #\0) (if upper? "E+00" "e+00")) - (let* ((sign (if (< n 0) "-" "")) - (abs-n (abs n)) - (e (inexact->exact (floor (/ (log abs-n) (log 10))))) - (mantissa (/ abs-n (expt 10.0 e)))) - ;; Adjust if mantissa rounds to 10 - (when (>= mantissa 10.0) - (set! mantissa (/ mantissa 10.0)) - (set! e (+ e 1))) - (let* ((mant-str (format-float-f mantissa prec)) - (exp-sign (if (>= e 0) "+" "-")) - (exp-str (number->string (abs e))) - (exp-str (if (< (string-length exp-str) 2) - (string-append "0" exp-str) exp-str))) - (string-append sign mant-str (if upper? "E" "e") exp-sign exp-str))))) - - (define (format-float-g n prec upper?) - "Format float in %g style" - (if (zero? n) - "0" - (let* ((abs-n (abs n)) - (e (if (zero? abs-n) 0 - (inexact->exact (floor (/ (log abs-n) (log 10)))))) - ;; Correct for floating-point imprecision - (e (if (>= abs-n (expt 10.0 (+ e 1))) (+ e 1) e))) - (if (and (>= e -4) (< e prec)) - ;; Use %f style, then strip trailing zeros - (let ((s (format-float-f n (- prec e 1)))) - (strip-trailing-zeros s)) - ;; Use %e style, then strip trailing zeros - (let ((s (format-float-e n (- prec 1) upper?))) - (strip-trailing-zeros-e s)))))) - - (define (strip-trailing-zeros s) - (if (string-contains s ".") - (let loop ((i (- (string-length s) 1))) - (cond - ((char=? (string-ref s i) #\0) (loop (- i 1))) - ((char=? (string-ref s i) #\.) (substring s 0 i)) - (else (substring s 0 (+ i 1))))) - s)) - - (define (strip-trailing-zeros-e s) - ;; Find the 'e' or 'E', strip zeros before it - (let ((epos (or (string-contains s "e") (string-contains s "E")))) - (if epos - (let ((before (substring s 0 epos)) - (after (substring s epos (string-length s)))) - (string-append (strip-trailing-zeros before) after)) - (strip-trailing-zeros s)))) - -) ;; end library deleted file mode 100644 --- a/lib/jerboa-awk/lexer.sls +++ /dev/null @@ -1,355 +0,0 @@ -#!chezscheme -;;;; AWK Lexer - -(library (jerboa-awk lexer) - (export - tok make-tok tok? tok-type tok-value tok-line tok-column - lexer make-lexer lexer? - lexer-pos lexer-len lexer-line lexer-column lexer-peeked lexer-last-type - lexer-pos-set! lexer-len-set! lexer-line-set! lexer-column-set! - lexer-peeked-set! lexer-last-type-set! - make-awk-lexer lex-next! lex-peek! lex-skip-newlines! lex-peek-ahead) - - (import (scheme)) - - ;;; Token - (define-record-type tok (fields type value line column)) - - ;;; Lexer state - (define-record-type lexer - (fields input - (mutable pos) (mutable len) (mutable line) (mutable column) - (mutable peeked) (mutable last-type))) - - (define (make-awk-lexer input) - (make-lexer input 0 (string-length input) 1 1 #f #f)) - - ;;; Keywords - (define +keywords+ - '(BEGIN END if else while for do break continue - function return delete exit next nextfile - print printf getline in)) - - ;;; Character utilities - - (define (lex-ch lex) - (if (>= (lexer-pos lex) (lexer-len lex)) - #f - (string-ref (lexer-input lex) (lexer-pos lex)))) - - (define (lex-ch+ lex offset) - (let ((p (+ (lexer-pos lex) offset))) - (if (>= p (lexer-len lex)) - #f - (string-ref (lexer-input lex) p)))) - - (define (lex-advance! lex) - (let ((c (lex-ch lex))) - (when c - (lexer-pos-set! lex (+ (lexer-pos lex) 1)) - (if (char=? c #\newline) - (begin (lexer-line-set! lex (+ (lexer-line lex) 1)) - (lexer-column-set! lex 1)) - (lexer-column-set! lex (+ (lexer-column lex) 1)))) - c)) - - (define (lex-skip-ws! lex) - (let loop () - (let ((c (lex-ch lex))) - (when (and c (char-whitespace? c) (not (char=? c #\newline))) - (lex-advance! lex) (loop))))) - - (define (lex-skip-line! lex) - (let loop () - (let ((c (lex-ch lex))) - (when (and c (not (char=? c #\newline))) - (lex-advance! lex) (loop))))) - - (define (lex-skip! lex) - (let loop () - (lex-skip-ws! lex) - (let ((c (lex-ch lex))) - (cond - ((and c (char=? c #\#)) - (lex-skip-line! lex) (loop)) - ((and c (char=? c #\\) (let ((n (lex-ch+ lex 1))) (and n (char=? n #\newline)))) - (lex-advance! lex) (lex-advance! lex) (loop)) - (else (void)))))) - - ;;; Token reading helpers - - (define (value-token? type) - (and type (memq type '(NUMBER STRING NAME RPAREN RBRACKET DOLLAR PLUSPLUS MINUSMINUS)))) - - (define (make-tok! lex type value) - (let ((t (make-tok type value (lexer-line lex) (lexer-column lex)))) - (lexer-last-type-set! lex type) - t)) - - ;;; Number reading - - (define (read-number lex) - (let ((line (lexer-line lex)) - (col (lexer-column lex)) - (c (lex-ch lex))) - (if (and (char=? c #\0) (let ((n (lex-ch+ lex 1))) (and n (char-ci=? n #\x)))) - (begin (lex-advance! lex) (lex-advance! lex) - (let loop ((chars '())) - (let ((c (lex-ch lex))) - (if (and c (or (char-numeric? c) (and (char-ci>=? c #\a) (char-ci<=? c #\f)))) - (begin (lex-advance! lex) (loop (cons c chars))) - (let* ((s (list->string (reverse chars))) - (n (or (string->number (string-append "#x" s)) 0))) - (lexer-last-type-set! lex 'NUMBER) - (make-tok 'NUMBER n line col)))))) - (let loop ((chars '()) (has-dot? #f) (has-exp? #f)) - (let ((c (lex-ch lex))) - (cond - ((and c (char-numeric? c)) - (lex-advance! lex) (loop (cons c chars) has-dot? has-exp?)) - ((and c (char=? c #\.) (not has-dot?) (not has-exp?)) - (lex-advance! lex) (loop (cons c chars) #t has-exp?)) - ((and c (char-ci=? c #\e) (not has-exp?)) - (lex-advance! lex) - (let ((c2 (lex-ch lex))) - (if (and c2 (or (char=? c2 #\+) (char=? c2 #\-))) - (begin (lex-advance! lex) - (loop (cons c2 (cons #\e chars)) has-dot? #t)) - (loop (cons #\e chars) has-dot? #t)))) - (else - (let* ((s (list->string (reverse chars))) - (n (or (string->number s) 0))) - (lexer-last-type-set! lex 'NUMBER) - (make-tok 'NUMBER n line col))))))))) - - ;;; String reading - - (define (read-string lex) - (let ((line (lexer-line lex)) - (col (lexer-column lex))) - (lex-advance! lex) - (let loop ((chars '())) - (let ((c (lex-ch lex))) - (cond - ((not c) (error 'read-string "unterminated string" line)) - ((char=? c #\") - (lex-advance! lex) - (lexer-last-type-set! lex 'STRING) - (make-tok 'STRING (list->string (reverse chars)) line col)) - ((char=? c #\\) - (lex-advance! lex) - (let ((e (lex-ch lex))) - (if e - (begin (lex-advance! lex) - (loop (cons (escape-char e) chars))) - (error 'read-string "unterminated string escape" line)))) - (else - (lex-advance! lex) - (loop (cons c chars)))))))) - - (define (escape-char c) - (case c - ((#\a) #\alarm) - ((#\b) #\backspace) - ((#\f) #\page) - ((#\n) #\newline) - ((#\r) #\return) - ((#\t) #\tab) - ((#\v) #\vtab) - ((#\\) #\\) - ((#\") #\") - ((#\/) #\/) - (else - (if (and (char>=? c #\0) (char<=? c #\7)) - (integer->char (- (char->integer c) (char->integer #\0))) - c)))) - - ;;; Regex reading - - (define (read-regex lex) - (let ((line (lexer-line lex)) - (col (lexer-column lex))) - (lex-advance! lex) - (let loop ((chars '())) - (let ((c (lex-ch lex))) - (cond - ((not c) (error 'read-regex "unterminated regex" line)) - ((char=? c #\/) - (lex-advance! lex) - (lexer-last-type-set! lex 'REGEX) - (make-tok 'REGEX (list->string (reverse chars)) line col)) - ((char=? c #\\) - (lex-advance! lex) - (let ((e (lex-ch lex))) - (when e (lex-advance! lex)) - (loop (cons (or e #\\) (cons #\\ chars))))) - (else - (lex-advance! lex) - (loop (cons c chars)))))))) - - ;;; Name reading - - (define (read-name lex) - (let ((line (lexer-line lex)) - (col (lexer-column lex)))