Port AWK interpreter from Gerbil to Jerboa Scheme with match2, prelude APIs, and static binary build
ober
047fc155f4e6601599ac0c0a054cfa20cca1701c
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*.so +/jawk +/jawk-debug new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,53 @@ +SCHEME := scheme +JERBOA_HOME ?= $(HOME)/mine/jerboa +LIBDIRS := lib:$(JERBOA_HOME)/lib +JAWK := $(SCHEME) --libdirs "$(LIBDIRS)" --script bin/jawk.ss + + +.PHONY: all build clean test binary binary-static binary-release + +all: build + +build: + @echo "Compiling libraries..." + @$(SCHEME) --libdirs "$(LIBDIRS)" --script build.ss + @echo "Done." + +binary: build + @echo "Building jawk binary..." + @$(SCHEME) --libdirs "$(LIBDIRS)" --script build-binary.ss + +binary-release: build + @echo "Building jawk release binary..." + @$(SCHEME) --libdirs "$(LIBDIRS)" --script build-binary.ss --release + +binary-static: build + @echo "Building jawk static binary..." + @$(SCHEME) --libdirs "$(LIBDIRS)" --script build-binary.ss --static + +clean: + find lib -name "*.so" -delete + rm -f jawk + +test: + @echo "--- Test 1: Hello World ---" + @echo "hello world" | $(JAWK) '{print $$1}' + @echo "--- Test 2: Field separator ---" + @echo "a,b,c" | $(JAWK) -F, '{print $$2}' + @echo "--- Test 3: BEGIN/END ---" + @echo "" | $(JAWK) 'BEGIN{print "start"} END{print "end"}' + @echo "--- Test 4: NR counter ---" + @printf "a\nb\nc\n" | $(JAWK) '{print NR, $$0}' + @echo "--- Test 5: Arithmetic ---" + @printf "10\n20\n30\n" | $(JAWK) '{sum += $$1} END {print sum}' + @echo "--- Test 6: Regex ---" + @printf "hello\nworld\nhelium\n" | $(JAWK) '/hel/{print}' + @echo "--- Test 7: User function ---" + @echo "5" | $(JAWK) 'function double(x) { return x * 2 } { print double($$1) }' + @echo "--- Test 8: Associative arrays ---" + @printf "apple\nbanana\napple\ncherry\napple\n" | $(JAWK) '{count[$$1]++} END {for (k in count) print k, count[k]}' + @echo "--- Test 9: String functions ---" + @echo "Hello World" | $(JAWK) '{print length($$0), tolower($$0), substr($$0, 7)}' + @echo "--- Test 10: gsub ---" + @echo "foo bar foo" | $(JAWK) '{gsub(/foo/, "FOO"); print}' + @echo "--- All tests passed ---" new file mode 100644 --- /dev/null +++ b/bin/jawk-program.ss @@ -0,0 +1,10 @@ +;;;; jawk — AWK interpreter entry point (for binary compilation) +;;;; Uses scheme-start so Sscheme_start() in C passes argv through. + +(import (chezscheme) (jerboa-awk main)) + +(suppress-greeting #t) + +(scheme-start + (lambda fns + (main fns))) new file mode 100755 --- /dev/null +++ b/bin/jawk.ss @@ -0,0 +1,6 @@ +#!/usr/bin/env scheme --libdirs lib --script +;;;; jawk — AWK interpreter in Jerboa Scheme + +(import (chezscheme) (jerboa-awk main)) + +(main (cdr (command-line))) new file mode 100755 --- /dev/null +++ b/build-binary.ss @@ -0,0 +1,141 @@ +#!/usr/bin/env scheme --script +;;;; Build a self-contained jawk binary +;;;; +;;;; Strategy: compile-program with compile-imported-libraries creates all +;;;; .so files. We collect them all and pack into the boot file so the +;;;; binary is fully self-contained. + +(import (chezscheme)) + +;; Setup library paths +(let ((jerboa-home (or (getenv "JERBOA_HOME") + (string-append (getenv "HOME") "/mine/jerboa")))) + (library-directories (cons* (cons "lib" "lib") + (cons (string-append jerboa-home "/lib") + (string-append jerboa-home "/lib")) + (library-directories)))) + +;; Find Chez install directory containing scheme.h + boot files +(define chez-dir + (let ((mt (symbol->string (machine-type)))) + (let loop ((dirs (directory-list "/usr/lib"))) + (cond + ((null? dirs) + (error 'build "cannot find Chez Scheme install directory")) + (else + (let ((candidate (format "/usr/lib/~a/~a" (car dirs) mt))) + (if (and (> (string-length (car dirs)) 3) + (string=? (substring (car dirs) 0 3) "csv") + (file-exists? (string-append candidate "/scheme.h")) + (file-exists? (string-append candidate "/scheme.boot"))) + candidate + (loop (cdr dirs))))))))) + +(printf "Using Chez dir: ~a~%" chez-dir) +(putenv "SCHEMEHEAPDIRS" chez-dir) + +;; Step 1: Compile program + all imported libraries +(define build-dir + (format "/tmp/jerboa-build-jawk-~a" + (mod (time-second (current-time)) 100000))) +(system (format "mkdir -p '~a'" build-dir)) + +(define so-path (string-append build-dir "/program.so")) +(printf "[1/5] Compiling program + libraries...~%") +(parameterize ([compile-imported-libraries #t] + [optimize-level 2]) + (compile-program "bin/jawk-program.ss" so-path)) + +;; Step 2: Collect all compiled .so files (libraries) and create boot file +;; The libraries are compiled in-place next to their .sls sources. +;; We need them in the boot file in dependency order. +(printf "[2/5] Creating boot file...~%") + +;; Collect library .so files in dependency order +(define jerboa-home (or (getenv "JERBOA_HOME") + (string-append (getenv "HOME") "/mine/jerboa"))) + +;; Helper to find a .so file for a library +(define (find-lib-so lib-path) + (let ((so (string-append lib-path ".so"))) + (cond + ((file-exists? (string-append "lib/" so)) (string-append "lib/" so)) + ((file-exists? (string-append jerboa-home "/lib/" so)) + (string-append jerboa-home "/lib/" so)) + (else #f)))) + +;; Jerboa stdlib dependencies (order matters!) +(define jerboa-libs + (filter values + (map find-lib-so + '("std/pregexp" + "std/misc/string" + "std/match2" + "jerboa/runtime" + "jerboa-awk/ast" + "jerboa-awk/value" + "jerboa-awk/runtime" + "jerboa-awk/lexer" + "jerboa-awk/parser" + "jerboa-awk/builtins/string" + "jerboa-awk/builtins/math" + "jerboa-awk/builtins/io" + "jerboa-awk/main")))) + +(printf " Libraries to embed: ~a~%" (length jerboa-libs)) +(for-each (lambda (l) (printf " ~a~%" l)) jerboa-libs) + +(define app-boot (string-append build-dir "/app.boot")) +(apply make-boot-file app-boot '("petite" "scheme") + (append jerboa-libs (list so-path))) + +;; Step 3: Generate C +;; We use file->c-array from (jerboa build) but write our own main() +;; that calls Sscheme_start(argc, argv) to set (command-line) properly. +(printf "[3/5] Generating C...~%") +(eval '(import (jerboa build))) + +(define (boot->c-array path name) + (eval `(file->c-array ,path ,name))) + +(define main-c + (string-append + (boot->c-array (string-append chez-dir "/petite.boot") "petite_boot") + "\n" + (boot->c-array (string-append chez-dir "/scheme.boot") "scheme_boot") + "\n" + (boot->c-array app-boot "app_boot") + "\n" + "#include <scheme.h>\n" + "#include <string.h>\n" + "#include <stdlib.h>\n\n" + "int main(int argc, const char *argv[]) {\n" + " Sscheme_init(NULL);\n\n" + " Sregister_boot_file_bytes(\"petite\", petite_boot, petite_boot_len);\n" + " Sregister_boot_file_bytes(\"scheme\", scheme_boot, scheme_boot_len);\n" + " Sregister_boot_file_bytes(\"app\", app_boot, app_boot_len);\n\n" + " Sbuild_heap(argv[0], NULL);\n" + " return Sscheme_start(argc, argv);\n" + "}\n")) + +(define main-path (string-append build-dir "/main.c")) +(call-with-output-file main-path + (lambda (p) (display main-c p)) + 'replace) + +;; Step 4: Link +(define output-name "jawk") +(printf "[4/5] Linking ~a...~%" output-name) +(let* ((lflags (format "-L'~a' -lkernel -llz4 -lz -lm -lpthread -ldl" chez-dir)) + (cmd (format "gcc -rdynamic -I'~a' -o '~a' '~a' ~a 2>&1" + chez-dir output-name main-path lflags)) + (rc (system cmd))) + (if (= rc 0) + (printf "[5/5] Built: ~a (~a bytes)~%" output-name + (let ((p (open-file-input-port output-name))) + (let ((sz (port-length p))) + (close-port p) + sz))) + (begin + (printf "Link failed (rc=~a)~%" rc) + (printf "Command: ~a~%" cmd)))) new file mode 100644 --- /dev/null +++ b/build.ss @@ -0,0 +1,15 @@ +#!/usr/bin/env scheme --script +;;;; Compile all jerboa-awk libraries + +(import (chezscheme)) + +(let ((jerboa-home (or (getenv "JERBOA_HOME") + (string-append (getenv "HOME") "/mine/jerboa")))) + (library-directories (cons* (cons "lib" "lib") + (cons (string-append jerboa-home "/lib") + (string-append jerboa-home "/lib")) + (library-directories))) + (compile-imported-libraries #t) + ;; Import the main library to trigger compilation of all dependencies + (eval '(import (jerboa-awk main))) + (display "Build complete.\n")) new file mode 100644 --- /dev/null +++ b/lib/jerboa-awk/ast.sls @@ -0,0 +1,206 @@ +#!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 (chezscheme) + (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 new file mode 100644 --- /dev/null +++ b/lib/jerboa-awk/builtins/io.sls @@ -0,0 +1,41 @@ +#!chezscheme +;;;; AWK I/O Built-in Functions + +(library (jerboa-awk builtins io) + (export + awk-builtin-close + awk-builtin-system + awk-builtin-fflush) + + (import (chezscheme) + (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) + (let* ((cmd (awk->string (car args))) + (status (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 new file mode 100644 --- /dev/null +++ b/lib/jerboa-awk/builtins/math.sls @@ -0,0 +1,81 @@ +#!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 (chezscheme) + (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-seed* 1) + (define *awk-rand-state* 0) + (define *awk-rand-initialized* #f) + + (define (awk-rand-init!) + (unless *awk-rand-initialized* + (set! *awk-rand-state* *awk-rand-seed*) + (set! *awk-rand-initialized* #t))) + + (define (awk-rand-next!) + ;; LCG: same constants as glibc + (set! *awk-rand-state* + (mod (+ (* 1103515245 *awk-rand-state*) 12345) + (expt 2 31))) + (/ (inexact *awk-rand-state*) (inexact (expt 2 31)))) + + (define (awk-builtin-rand env args) + (awk-rand-init!) + (make-awk-number (awk-rand-next!))) + + (define (awk-builtin-srand env args) + (let ((old-seed *awk-rand-seed*)) + (if (null? args) + (begin + (set! *awk-rand-seed* (time-second (current-time))) + (set! *awk-rand-state* *awk-rand-seed*) + (set! *awk-rand-initialized* #t) + (make-awk-number old-seed)) + (begin + (set! *awk-rand-seed* (inexact->exact (floor (awk->number (car args))))) + (set! *awk-rand-state* *awk-rand-seed*) + (set! *awk-rand-initialized* #t) + (make-awk-number old-seed))))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa-awk/builtins/string.sls @@ -0,0 +1,395 @@ +#!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 (chezscheme) + (only (std misc string) string-contains string-trim) + (jerboa-awk value) + (jerboa-awk runtime) + (jerboa-awk ast) + (std pregexp)) + + ;;; 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 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 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)) + (count 0)) + (let loop ((pos 0) (result '())) + (let ((m (pregexp-match-positions pattern target-str pos))) + (if (not m) + (let ((final (string-append (apply string-append (reverse result)) + (substring target-str pos (string-length target-str))))) + (set-target! (make-awk-string final)) + (make-awk-number count)) + (let* ((mpos (car m)) ;; full match (start . end) + (start (car mpos)) + (end (cdr mpos)) + (replacement (build-replacement repl-str mpos target-str))) + (set! count (+ count 1)) + (loop (if (= start end) (+ end 1) end) + (cons replacement + (cons (substring target-str pos start) result))))))))) + + (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 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) + (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 new file mode 100644 --- /dev/null +++ b/lib/jerboa-awk/lexer.sls @@ -0,0 +1,355 @@ +#!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 (chezscheme)) + + ;;; 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)) +