Port gerbil-sed to Jerboa/Chez Scheme with native optimizations
ober
9a080ea0155192b8114a200d59b96d53461fc103
new file mode 100644 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.so +jsed new file mode 100644 --- /dev/null +++ b/Makefile @@ -0,0 +1,35 @@ +SCHEME := scheme +JSED_BIN := jsed +LIBDIRS := lib + +.PHONY: all build clean test install + +all: build + +build: + @echo "Building jsed..." + $(SCHEME) --libdirs $(LIBDIRS) --compile-imported-libraries --script main.ss --version 2>/dev/null || true + @echo "Build complete. Run with: $(SCHEME) --libdirs $(LIBDIRS) --script main.ss" + +clean: + find lib -name '*.so' -delete 2>/dev/null || true + rm -f $(JSED_BIN) + +test: + @echo "Running basic tests..." + @echo "hello world" | $(SCHEME) --libdirs $(LIBDIRS) --script main.ss 's/hello/goodbye/' + @echo "Test: line numbers" + @printf "a\nb\nc\n" | $(SCHEME) --libdirs $(LIBDIRS) --script main.ss '=' + @echo "Test: delete" + @printf "a\nb\nc\n" | $(SCHEME) --libdirs $(LIBDIRS) --script main.ss '2d' + @echo "Test: substitute global" + @echo "aaa" | $(SCHEME) --libdirs $(LIBDIRS) --script main.ss 's/a/b/g' + @echo "Test: hold space" + @printf "1\n2\n3\n" | $(SCHEME) --libdirs $(LIBDIRS) --script main.ss -n '1h;2{x;p};3{x;p}' + @echo "All tests passed." + +install: build + @echo '#!/bin/sh' > $(JSED_BIN) + @echo 'exec $(SCHEME) --libdirs $(LIBDIRS) --script main.ss "$$@"' >> $(JSED_BIN) + @chmod +x $(JSED_BIN) + @echo "Created ./$(JSED_BIN) wrapper script" new file mode 100644 --- /dev/null +++ b/lib/sed/ast.sls @@ -0,0 +1,159 @@ +#!chezscheme +;;; Sed AST node definitions + +(library (sed ast) + (export + ;; Address types + sed-addr-line make-sed-addr-line sed-addr-line? sed-addr-line-n + sed-addr-last make-sed-addr-last sed-addr-last? + sed-addr-regex make-sed-addr-regex sed-addr-regex? sed-addr-regex-pattern sed-addr-regex-icase + sed-addr-step make-sed-addr-step sed-addr-step? sed-addr-step-first sed-addr-step-step + ;; Address wrappers + sed-single-addr make-sed-single-addr sed-single-addr? sed-single-addr-addr sed-single-addr-negated? + sed-range-addr make-sed-range-addr sed-range-addr? sed-range-addr-start sed-range-addr-end sed-range-addr-negated? + ;; s-command flags + sed-s-flags make-sed-s-flags sed-s-flags? + sed-s-flags-global? sed-s-flags-global?-set! + sed-s-flags-nth sed-s-flags-nth-set! + sed-s-flags-print? sed-s-flags-print?-set! + sed-s-flags-icase? sed-s-flags-icase?-set! + sed-s-flags-multiline? sed-s-flags-multiline?-set! + sed-s-flags-exec? sed-s-flags-exec?-set! + sed-s-flags-write-file sed-s-flags-write-file-set! + make-default-s-flags + ;; Commands + sed-cmd-d make-sed-cmd-d sed-cmd-d? sed-cmd-d-addr + sed-cmd-D make-sed-cmd-D sed-cmd-D? sed-cmd-D-addr + sed-cmd-p make-sed-cmd-p sed-cmd-p? sed-cmd-p-addr + sed-cmd-P make-sed-cmd-P sed-cmd-P? sed-cmd-P-addr + sed-cmd-q make-sed-cmd-q sed-cmd-q? sed-cmd-q-addr sed-cmd-q-code + sed-cmd-Q make-sed-cmd-Q sed-cmd-Q? sed-cmd-Q-addr sed-cmd-Q-code + sed-cmd-n make-sed-cmd-n sed-cmd-n? sed-cmd-n-addr + sed-cmd-N make-sed-cmd-N sed-cmd-N? sed-cmd-N-addr + sed-cmd-h make-sed-cmd-h sed-cmd-h? sed-cmd-h-addr + sed-cmd-H make-sed-cmd-H sed-cmd-H? sed-cmd-H-addr + sed-cmd-g make-sed-cmd-g sed-cmd-g? sed-cmd-g-addr + sed-cmd-G make-sed-cmd-G sed-cmd-G? sed-cmd-G-addr + sed-cmd-x make-sed-cmd-x sed-cmd-x? sed-cmd-x-addr + sed-cmd-l make-sed-cmd-l sed-cmd-l? sed-cmd-l-addr sed-cmd-l-width + sed-cmd-= make-sed-cmd-= sed-cmd-=? sed-cmd-=-addr + sed-cmd-z make-sed-cmd-z sed-cmd-z? sed-cmd-z-addr + sed-cmd-F make-sed-cmd-F sed-cmd-F? sed-cmd-F-addr + sed-cmd-a make-sed-cmd-a sed-cmd-a? sed-cmd-a-addr sed-cmd-a-text + sed-cmd-i make-sed-cmd-i sed-cmd-i? sed-cmd-i-addr sed-cmd-i-text + sed-cmd-c make-sed-cmd-c sed-cmd-c? sed-cmd-c-addr sed-cmd-c-text + sed-cmd-r make-sed-cmd-r sed-cmd-r? sed-cmd-r-addr sed-cmd-r-filename + sed-cmd-R make-sed-cmd-R sed-cmd-R? sed-cmd-R-addr sed-cmd-R-filename + sed-cmd-w make-sed-cmd-w sed-cmd-w? sed-cmd-w-addr sed-cmd-w-filename + sed-cmd-W make-sed-cmd-W sed-cmd-W? sed-cmd-W-addr sed-cmd-W-filename + sed-cmd-e make-sed-cmd-e sed-cmd-e? sed-cmd-e-addr sed-cmd-e-cmd + sed-cmd-b make-sed-cmd-b sed-cmd-b? sed-cmd-b-addr sed-cmd-b-label + sed-cmd-t make-sed-cmd-t sed-cmd-t? sed-cmd-t-addr sed-cmd-t-label + sed-cmd-T make-sed-cmd-T sed-cmd-T? sed-cmd-T-addr sed-cmd-T-label + sed-cmd-label make-sed-cmd-label sed-cmd-label? sed-cmd-label-name + sed-cmd-s make-sed-cmd-s sed-cmd-s? sed-cmd-s-addr sed-cmd-s-pattern sed-cmd-s-replacement sed-cmd-s-flags + sed-cmd-y make-sed-cmd-y sed-cmd-y? sed-cmd-y-addr sed-cmd-y-src sed-cmd-y-dst + sed-cmd-block make-sed-cmd-block sed-cmd-block? sed-cmd-block-addr sed-cmd-block-cmds + ;; Flat compilation + sed-flat-jump make-sed-flat-jump sed-flat-jump? sed-flat-jump-addr sed-flat-jump-target + ;; Address extraction + cmd-addr) + (import (chezscheme)) + + ;;; Address primitives + (define-record-type sed-addr-line (fields n)) + (define-record-type sed-addr-last) + (define-record-type sed-addr-regex (fields pattern icase)) + (define-record-type sed-addr-step (fields first step)) + + ;;; Address wrappers + (define-record-type sed-single-addr (fields addr negated?)) + (define-record-type sed-range-addr (fields start end negated?)) + + ;;; s-command flags (mutable for parser to fill in) + (define-record-type sed-s-flags + (fields (mutable global?) + (mutable nth) + (mutable print?) + (mutable icase?) + (mutable multiline?) + (mutable exec?) + (mutable write-file))) + + (define (make-default-s-flags) + (make-sed-s-flags #f #f #f #f #f #f #f)) + + ;;; Commands + (define-record-type sed-cmd-d (fields addr)) + (define-record-type sed-cmd-D (fields addr)) + (define-record-type sed-cmd-p (fields addr)) + (define-record-type sed-cmd-P (fields addr)) + (define-record-type sed-cmd-q (fields addr code)) + (define-record-type sed-cmd-Q (fields addr code)) + (define-record-type sed-cmd-n (fields addr)) + (define-record-type sed-cmd-N (fields addr)) + (define-record-type sed-cmd-h (fields addr)) + (define-record-type sed-cmd-H (fields addr)) + (define-record-type sed-cmd-g (fields addr)) + (define-record-type sed-cmd-G (fields addr)) + (define-record-type sed-cmd-x (fields addr)) + (define-record-type sed-cmd-l (fields addr width)) + (define-record-type sed-cmd-= (fields addr)) + (define-record-type sed-cmd-z (fields addr)) + (define-record-type sed-cmd-F (fields addr)) + (define-record-type sed-cmd-a (fields addr text)) + (define-record-type sed-cmd-i (fields addr text)) + (define-record-type sed-cmd-c (fields addr text)) + (define-record-type sed-cmd-r (fields addr filename)) + (define-record-type sed-cmd-R (fields addr filename)) + (define-record-type sed-cmd-w (fields addr filename)) + (define-record-type sed-cmd-W (fields addr filename)) + (define-record-type sed-cmd-e (fields addr cmd)) + (define-record-type sed-cmd-b (fields addr label)) + (define-record-type sed-cmd-t (fields addr label)) + (define-record-type sed-cmd-T (fields addr label)) + (define-record-type sed-cmd-label (fields name)) + (define-record-type sed-cmd-s (fields addr pattern replacement flags)) + (define-record-type sed-cmd-y (fields addr src dst)) + (define-record-type sed-cmd-block (fields addr cmds)) + + ;;; Flat compilation instruction + (define-record-type sed-flat-jump (fields addr target)) + + ;;; Command address extraction (used by engine) + (define (cmd-addr cmd) + (cond + [(sed-cmd-d? cmd) (sed-cmd-d-addr cmd)] + [(sed-cmd-D? cmd) (sed-cmd-D-addr cmd)] + [(sed-cmd-p? cmd) (sed-cmd-p-addr cmd)] + [(sed-cmd-P? cmd) (sed-cmd-P-addr cmd)] + [(sed-cmd-q? cmd) (sed-cmd-q-addr cmd)] + [(sed-cmd-Q? cmd) (sed-cmd-Q-addr cmd)] + [(sed-cmd-n? cmd) (sed-cmd-n-addr cmd)] + [(sed-cmd-N? cmd) (sed-cmd-N-addr cmd)] + [(sed-cmd-h? cmd) (sed-cmd-h-addr cmd)] + [(sed-cmd-H? cmd) (sed-cmd-H-addr cmd)] + [(sed-cmd-g? cmd) (sed-cmd-g-addr cmd)] + [(sed-cmd-G? cmd) (sed-cmd-G-addr cmd)] + [(sed-cmd-x? cmd) (sed-cmd-x-addr cmd)] + [(sed-cmd-l? cmd) (sed-cmd-l-addr cmd)] + [(sed-cmd-=? cmd) (sed-cmd-=-addr cmd)] + [(sed-cmd-z? cmd) (sed-cmd-z-addr cmd)] + [(sed-cmd-F? cmd) (sed-cmd-F-addr cmd)] + [(sed-cmd-a? cmd) (sed-cmd-a-addr cmd)] + [(sed-cmd-i? cmd) (sed-cmd-i-addr cmd)] + [(sed-cmd-c? cmd) (sed-cmd-c-addr cmd)] + [(sed-cmd-r? cmd) (sed-cmd-r-addr cmd)] + [(sed-cmd-R? cmd) (sed-cmd-R-addr cmd)] + [(sed-cmd-w? cmd) (sed-cmd-w-addr cmd)] + [(sed-cmd-W? cmd) (sed-cmd-W-addr cmd)] + [(sed-cmd-e? cmd) (sed-cmd-e-addr cmd)] + [(sed-cmd-b? cmd) (sed-cmd-b-addr cmd)] + [(sed-cmd-t? cmd) (sed-cmd-t-addr cmd)] + [(sed-cmd-T? cmd) (sed-cmd-T-addr cmd)] + [(sed-cmd-s? cmd) (sed-cmd-s-addr cmd)] + [(sed-cmd-y? cmd) (sed-cmd-y-addr cmd)] + [(sed-cmd-label? cmd) #f] + [else #f])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/sed/engine.sls @@ -0,0 +1,739 @@ +#!chezscheme +;;; Sed execution engine + +(library (sed engine) + (export + make-initial-sed-state sed-state? + sed-state-pattern-space sed-state-pattern-space-set! + sed-state-hold-space sed-state-hold-space-set! + sed-state-line-num sed-state-line-num-set! + sed-state-last-line? sed-state-last-line?-set! + sed-state-sub-succeeded? sed-state-sub-succeeded?-set! + sed-state-append-queue sed-state-append-queue-set! + sed-state-suppress? sed-state-extended? + sed-state-sandbox? sed-state-null-data? + sed-state-separate? + sed-state-filename sed-state-filename-set! + sed-state-range-states sed-state-open-write-files + sed-program make-sed-program sed-program? sed-program-cmds sed-program-labels + compile-program + run-sed-cycle-from! + flush-append-queue!) + (import (except (chezscheme) compile-program) (sed ast) (sed pcre2)) + + ;;; Execution state + (define-record-type sed-state + (fields (mutable pattern-space) + (mutable hold-space) + (mutable line-num) + (mutable last-line?) + (mutable sub-succeeded?) + (mutable append-queue) + suppress? + extended? + sandbox? + null-data? + separate? + (mutable filename) + range-states ; eq-hashtable: pc -> (in-range? . end-matched?) + open-write-files)) ; string-hashtable: filename -> port + + (define (make-initial-sed-state suppress? extended? sandbox? null-data? separate?) + (make-sed-state + "" "" ; pattern-space, hold-space + 0 #f #f '() ; line-num, last-line?, sub-succeeded?, append-queue + suppress? extended? sandbox? null-data? separate? + "" ; filename + (make-eq-hashtable) + (make-hashtable string-hash string=?))) + + ;;; Compiled program + (define-record-type sed-program (fields cmds labels)) + + ;;; Compile tree -> flat vector + (define (compile-program cmds) + (let ([buf (make-vector 2048 #f)] + [pc (box 0)] + [labels (make-hashtable string-hash string=?)]) + (define (emit! instr) + (vector-set! buf (unbox pc) instr) + (set-box! pc (fx+ (unbox pc) 1))) + (define (compile-list! lst) + (for-each compile-one! lst)) + (define (compile-one! cmd) + (cond + [(sed-cmd-block? cmd) + (let ([jump-idx (unbox pc)]) + (emit! #f) + (compile-list! (sed-cmd-block-cmds cmd)) + (vector-set! buf jump-idx + (make-sed-flat-jump (sed-cmd-block-addr cmd) + (unbox pc))))] + [(sed-cmd-label? cmd) + (hashtable-set! labels (sed-cmd-label-name cmd) (unbox pc))] + [else + (emit! cmd)])) + (compile-list! cmds) + (make-sed-program + (let ([n (unbox pc)]) + (let ([v (make-vector n)]) + (do ([i 0 (fx+ i 1)]) + ((fx= i n) v) + (vector-set! v i (vector-ref buf i))))) + labels))) + + ;;; BRE to PCRE2 conversion + (define (bre->pcre2 pattern) + (let ([out (open-output-string)] + [len (string-length pattern)]) + (let loop ([i 0]) + (if (fx>= i len) + (get-output-string out) + (let ([c (string-ref pattern i)]) + (cond + ;; Character class: copy verbatim + [(char=? c #\[) + (write-char #\[ out) + (let* ([i1 (fx+ i 1)] + [i2 (if (and (fx< i1 len) (char=? (string-ref pattern i1) #\^)) + (begin (write-char #\^ out) (fx+ i1 1)) + i1)] + [i3 (if (and (fx< i2 len) (char=? (string-ref pattern i2) #\])) + (begin (write-char #\] out) (fx+ i2 1)) + i2)]) + (let class-loop ([j i3]) + (if (fx>= j len) + (loop j) + (let ([cc (string-ref pattern j)]) + (cond + [(char=? cc #\]) + (write-char #\] out) + (loop (fx+ j 1))] + [(char=? cc #\\) + (write-char #\\ out) + (if (fx< (fx+ j 1) len) + (begin + (write-char (string-ref pattern (fx+ j 1)) out) + (class-loop (fx+ j 2))) + (loop (fx+ j 1)))] + [else + (write-char cc out) + (class-loop (fx+ j 1))])))))] + ;; Backslash sequences + [(char=? c #\\) + (if (fx>= (fx+ i 1) len) + (begin (write-char #\\ out) (loop (fx+ i 1))) + (let ([next (string-ref pattern (fx+ i 1))]) + (case next + [(#\() (write-char #\( out) (loop (fx+ i 2))] + [(#\)) (write-char #\) out) (loop (fx+ i 2))] + [(#\{) + (write-char #\{ out) + (let int-loop ([j (fx+ i 2)]) + (if (fx>= j len) + (loop j) + (let ([ic (string-ref pattern j)]) + (if (and (char=? ic #\\) + (fx< (fx+ j 1) len) + (char=? (string-ref pattern (fx+ j 1)) #\})) + (begin (write-char #\} out) (loop (fx+ j 2))) + (begin (write-char ic out) (int-loop (fx+ j 1)))))))] + [(#\}) (write-char #\} out) (loop (fx+ i 2))] + [(#\+) (write-char #\+ out) (loop (fx+ i 2))] + [(#\?) (write-char #\? out) (loop (fx+ i 2))] + [(#\|) (write-char #\| out) (loop (fx+ i 2))] + [else + (write-char #\\ out) + (write-char next out) + (loop (fx+ i 2))])))] + ;; BRE literals that are PCRE2 operators + [(char=? c #\() (put-string out "\\(") (loop (fx+ i 1))] + [(char=? c #\)) (put-string out "\\)") (loop (fx+ i 1))] + [(char=? c #\{) (put-string out "\\{") (loop (fx+ i 1))] + [(char=? c #\+) (put-string out "\\+") (loop (fx+ i 1))] + [(char=? c #\?) (put-string out "\\?") (loop (fx+ i 1))] + [(char=? c #\|) (put-string out "\\|") (loop (fx+ i 1))] + [else + (write-char c out) + (loop (fx+ i 1))])))))) + + (define (pattern->pcre2 pattern extended?) + (if extended? pattern (bre->pcre2 pattern))) + + ;;; PCRE2 compilation helper + (define (compile-rx pattern icase? multiline? extended?) + (let ([pat (string-append "(?:" (pattern->pcre2 pattern extended?) ")")] + [flags 0]) + (when icase? (set! flags (fxior flags PCRE2_CASELESS))) + (when multiline? (set! flags (fxior flags PCRE2_MULTILINE))) + (pcre2-compile pat flags))) + + ;;; Address matching + (define (addr-primitive-matches? addr state) + (cond + [(sed-addr-line? addr) + (fx= (sed-state-line-num state) (sed-addr-line-n addr))] + [(sed-addr-last? addr) + (sed-state-last-line? state)] + [(sed-addr-regex? addr) + (let ([rx (compile-rx (sed-addr-regex-pattern addr) + (sed-addr-regex-icase addr) #f + (sed-state-extended? state))]) + (pcre2-matches? rx (sed-state-pattern-space state)))] + [(sed-addr-step? addr) + (let ([first (sed-addr-step-first addr)] + [step (sed-addr-step-step addr)] + [n (sed-state-line-num state)]) + (if (fx= step 0) + (fx= n first) + (and (fx>= n first) (fx= 0 (fxmod (fx- n first) step)))))] + [else #f])) + + (define (addr-matches? addr state pc range-states) + (cond + [(not addr) #t] + [(sed-single-addr? addr) + (let ([m (addr-primitive-matches? (sed-single-addr-addr addr) state)]) + (if (sed-single-addr-negated? addr) (not m) m))] + [(sed-range-addr? addr) + (let* ([rs (hashtable-ref range-states pc #f)] + [in-r? (if rs (car rs) #f)] + [start (sed-range-addr-start addr)] + [end (sed-range-addr-end addr)] + [result + (if in-r? + (let ([end-m? (addr-primitive-matches? end state)]) + (if end-m? + (hashtable-set! range-states pc (cons #f #t)) + (hashtable-set! range-states pc (cons #t #f))) + #t) + (let ([start-m? + (if (and (sed-addr-line? start) (fx= 0 (sed-addr-line-n start))) + (fx<= (sed-state-line-num state) 1) + (addr-primitive-matches? start state))]) + (when start-m? + (let ([end-m? (addr-primitive-matches? end state)]) + (if end-m? + (hashtable-set! range-states pc (cons #f #t)) + (hashtable-set! range-states pc (cons #t #f))))) + start-m?))]) + (if (sed-range-addr-negated? addr) (not result) result))] + [else #f])) + + (define (range-last-line? addr pc range-states) + (and (sed-range-addr? addr) + (let ([rs (hashtable-ref range-states pc #f)]) + (and rs (cdr rs))))) + + ;;; Substitution replacement + (define (expand-replacement repl m) + (let ([out (open-output-string)] + [len (string-length repl)]) + (let loop ([i 0] [mode 'normal]) + (if (fx>= i len) + (get-output-string out) + (let ([c (string-ref repl i)]) + (cond + [(char=? c #\&) + (output-cased out (or (pcre-match-group m 0) "") mode) + (loop (fx+ i 1) (next-mode mode))] + [(char=? c #\\) + (if (fx>= (fx+ i 1) len) + (begin (write-char #\\ out) (loop (fx+ i 1) mode)) + (let ([next (string-ref repl (fx+ i 1))]) + (case next + [(#\&) + (output-cased out "&" mode) + (loop (fx+ i 2) (next-mode mode))] + [(#\\) + (output-cased out "\\" mode) + (loop (fx+ i 2) (next-mode mode))] + [(#\n) + (write-char #\newline out) + (loop (fx+ i 2) (next-mode mode))] + [(#\l) (loop (fx+ i 2) 'lower-next)] + [(#\u) (loop (fx+ i 2) 'upper-next)] + [(#\L) (loop (fx+ i 2) 'lower-all)] + [(#\U) (loop (fx+ i 2) 'upper-all)] + [(#\E) (loop (fx+ i 2) 'normal)] + [else + (let ([code (char->integer next)]) + (if (and (fx>= code 49) (fx<= code 57)) + (let ([grp (or (pcre-match-group m (fx- code 48)) "")]) + (output-cased out grp mode) + (loop (fx+ i 2) (next-mode mode))) + (begin + (output-cased out (string next) mode) + (loop (fx+ i 2) (next-mode mode)))))])))] + [else + (output-cased out (string c) mode) + (loop (fx+ i 1) (next-mode mode))])))))) + + (define (output-cased out s mode) + (case mode + [(lower-next) + (unless (string=? s "") + (write-char (char-downcase (string-ref s 0)) out) + (put-string out (substring s 1 (string-length s))))] + [(upper-next) + (unless (string=? s "") + (write-char (char-upcase (string-ref s 0)) out) + (put-string out (substring s 1 (string-length s))))] + [(lower-all) (put-string out (string-downcase s))] + [(upper-all) (put-string out (string-upcase s))] + [else (put-string out s)])) + + (define (next-mode mode) + (case mode + [(lower-next upper-next) 'normal] + [else mode])) + + ;;; Substitution execution + (define (do-substitute! state cmd pc rs) + (let* ([flags (sed-cmd-s-flags cmd)] + [global? (sed-s-flags-global? flags)] + [nth (sed-s-flags-nth flags)] + [icase? (sed-s-flags-icase? flags)] + [mline? (sed-s-flags-multiline? flags)] + [rx (compile-rx (sed-cmd-s-pattern cmd) icase? mline? + (sed-state-extended? state))] + [repl (sed-cmd-s-replacement cmd)] + [subject (sed-state-pattern-space state)] + [result (if global? + (gsub rx subject repl) + (sub-nth rx subject repl (or nth 1)))]) + (when result + (sed-state-pattern-space-set! state result) + (sed-state-sub-succeeded?-set! state #t)) + (if result #t #f))) + + (define (sub-nth rx subject repl nth) + (let loop ([start 0] [count 0]) + (let ([m (pcre2-search rx subject start)]) + (and m + (let* ([pos (pcre-match-positions m 0)] + [ms (car pos)] + [me (cdr pos)] + [count (fx+ count 1)]) + (if (fx= count nth) + (string-append (substring subject 0 ms) + (expand-replacement repl m) + (substring subject me (string-length subject))) + (loop (if (fx= ms me) (fx+ me 1) me) count))))))) + + (define (gsub rx subject repl) + (let ([slen (string-length subject)]) + (let loop ([start 0] [prev-end -1] [parts '()] [found? #f]) + (if (fx> start slen) + (and found? (apply string-append (reverse parts))) + (let ([m (pcre2-search rx subject start)]) + (if (not m) + (and found? + (apply string-append + (reverse (cons (substring subject start slen) parts)))) + (let* ([pos (pcre-match-positions m 0)] + [ms (car pos)] + [me (cdr pos)] + [empty? (fx= ms me)]) + (if (and empty? (fx= ms prev-end)) + (if (fx< ms slen) + (loop (fx+ ms 1) prev-end + (cons (substring subject ms (fx+ ms 1)) parts) + found?) + (and found? (apply string-append (reverse parts)))) + (let ([before (substring subject start ms)] + [rtext (expand-replacement repl m)]) + (if empty? + (loop (fx+ me 1) me + (cons (if (fx< me slen) + (substring subject me (fx+ me 1)) + "") + (cons rtext (cons before parts))) + #t) + (loop me me + (cons rtext (cons before parts)) + #t))))))))))) + + ;;; y (transliterate) — use fxvector for O(1) char lookup + (define (do-transliterate! state cmd) + (let* ([src (sed-cmd-y-src cmd)] + [dst (sed-cmd-y-dst cmd)] + [slen (string-length src)] + [ps (sed-state-pattern-space state)] + [plen (string-length ps)]) + ;; Build lookup table for ASCII range + fallback for non-ASCII + (if (fx<= slen 0) + (void) + (let ([table (make-fxvector 256 -1)]) + ;; Fill table + (do ([j 0 (fx+ j 1)]) + ((fx= j slen)) + (let ([ci (char->integer (string-ref src j))]) + (when (fx< ci 256) + (fxvector-set! table ci (char->integer (string-ref dst j)))))) + ;; Translate + (let ([out (make-string plen)]) + (do ([i 0 (fx+ i 1)]) + ((fx= i plen) + (sed-state-pattern-space-set! state out)) + (let* ([c (string-ref ps i)] + [ci (char->integer c)]) + (if (and (fx< ci 256) (fx>= (fxvector-ref table ci) 0)) + (string-set! out i (integer->char (fxvector-ref table ci))) + ;; Fallback: linear scan for non-ASCII + (let find ([j 0]) + (cond + [(fx>= j slen) (string-set! out i c)] + [(char=? c (string-ref src j)) + (string-set! out i (string-ref dst j))] + [else (find (fx+ j 1))])))))))))) + + ;;; l command: print unambiguously + (define (do-l-cmd! state width out-port) + (let ([ps (sed-state-pattern-space state)]) + (let loop ([i 0] [col 0] [line-buf (open-output-string)]) + (define (flush-line!) + (put-string out-port (get-output-string line-buf)) + (put-string out-port "\\\n")) + (if (fx>= i (string-length ps)) + (begin + (put-string out-port (get-output-string line-buf)) + (put-string out-port "$\n")) + (let* ([c (string-ref ps i)] + [repr (cond + [(char=? c #\\) "\\\\"] + [(char=? c #\newline) "\\n"] + [(char=? c #\tab) "\\t"] + [(char=? c (integer->char 7)) "\\a"] + [(char=? c (integer->char 13)) "\\r"] + [(fx< (char->integer c) 32) + (let ([n (char->integer c)]) + (string-append "\\0" + (number->string (fxquotient n 64)) + (number->string (fxquotient (fxmod n 64) 8)) + (number->string (fxmod n 8))))] + [(fx= (char->integer c) 127) "\\177"] + [else (string c)])] + [rlen (string-length repr)]) + (if (fx>= (fx+ col rlen) (fx- width 1)) + (begin + (flush-line!) + (loop i 0 (open-output-string))) + (begin + (put-string line-buf repr) + (loop (fx+ i 1) (fx+ col rlen) line-buf)))))))) + + ;;; File/shell helpers + (define (write-to-file! state filename text) + (unless (sed-state-sandbox? state) + (let ([ht (sed-state-open-write-files state)]) + (let ([port (or (hashtable-ref ht filename #f) + (let ([p (open-file-output-port filename + (file-options no-fail) + (buffer-mode block) + (make-transcoder (utf-8-codec)))]) + (hashtable-set! ht filename p) + p))]) + (put-string port text) + (newline port) + (flush-output-port port))))) + + (define (flush-append-queue! state out-port) + (for-each + (lambda (item) + (cond + [(string? item) + (put-string out-port item) + (newline out-port)] + [(and (pair? item) (eq? (car item) 'file)) + (guard (e [else (void)]) + (call-with-input-file (cdr item) + (lambda (p) + (let loop () + (let ([line (get-line p)]) + (unless (eof-object? line) + (put-string out-port line) + (newline out-port) + (loop)))))))] + [(and (pair? item) (eq? (car item) 'file-line)) + (guard (e [else (void)]) + (call-with-input-file (cdr item) + (lambda (p) + (let ([line (get-line p)]) + (unless (eof-object? line) + (put-string out-port line) + (newline out-port))))))])) + (sed-state-append-queue state)) + (sed-state-append-queue-set! state '())) + + (define (exec-shell! cmd) + (guard (e [else ""]) + (call-with-values + (lambda () + (open-process-ports + (string-append "/bin/sh -c " (shell-quote cmd)) + (buffer-mode block) + (make-transcoder (utf-8-codec)))) + (lambda (to-stdin from-stdout from-stderr pid) + (close-port to-stdin) + (let ([result (get-string-all from-stdout)]) + (close-port from-stdout) + (close-port from-stderr) + (if (eof-object? result) "" result)))))) + + (define (shell-quote s) + (string-append "'" (let loop ([i 0] [out (open-output-string)]) + (if (fx>= i (string-length s)) + (get-output-string out) + (let ([c (string-ref s i)]) + (if (char=? c #\') + (begin (put-string out "'\"'\"'") (loop (fx+ i 1) out)) + (begin (write-char c out) (loop (fx+ i 1) out)))))) + "'")) + + ;;; String utility + (define (string-index-char s c) + (let ([len (string-length s)]) + (let loop ([i 0]) + (cond + [(fx>= i len) #f] + [(char=? (string-ref s i) c) i] + [else (loop (fx+ i 1))])))) + + ;;; Main execution + (define (run-sed-cycle-from! state prog out-port start-pc) + (let ([cmds (sed-program-cmds prog)] + [labels (sed-program-labels prog)] + [rs (sed-state-range-states state)]) + (call/1cc + (lambda (k-done) + (let pc-loop ([pc start-pc]) + (if (fx>= pc (vector-length cmds)) + (begin + (unless (sed-state-suppress? state) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (flush-append-queue! state out-port) + (k-done 'next)) + (let ([instr (vector-ref cmds pc)]) + (if (sed-flat-jump? instr) + (if (addr-matches? (sed-flat-jump-addr instr) state pc rs) + (pc-loop (fx+ pc 1)) + (pc-loop (sed-flat-jump-target instr))) + (if (addr-matches? (cmd-addr instr) state pc rs) + (let ([sig (exec-cmd! state instr pc rs out-port labels)]) + (case sig + [(continue) (pc-loop (fx+ pc 1))] + [(end-cycle) + (unless (sed-state-suppress? state) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (flush-append-queue! state out-port) + (k-done 'next)] + [(delete) + (sed-state-append-queue-set! state '()) + (k-done 'next)] + [(restart) + (k-done 'restart)] + [else + (if (and (pair? sig) (eq? (car sig) 'branch)) + (pc-loop (cdr sig)) + (k-done sig))])) + (pc-loop (fx+ pc 1))))))))))) + + (define (exec-cmd! state cmd pc rs out-port labels) + (cond + ;; d: delete + [(sed-cmd-d? cmd) 'delete] + ;; D: delete first line of PS + [(sed-cmd-D? cmd) + (let* ([ps (sed-state-pattern-space state)] + [nl (string-index-char ps #\newline)]) + (if nl + (begin + (sed-state-pattern-space-set! state + (substring ps (fx+ nl 1) (string-length ps))) + 'restart) + 'delete))] + ;; p: print + [(sed-cmd-p? cmd) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port) + 'continue] + ;; P: print first line + [(sed-cmd-P? cmd) + (let* ([ps (sed-state-pattern-space state)] + [nl (string-index-char ps #\newline)]) + (put-string out-port (if nl (substring ps 0 nl) ps)) + (newline out-port)) + 'continue] + ;; q: quit with default output + [(sed-cmd-q? cmd) + (unless (sed-state-suppress? state) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (flush-append-queue! state out-port) + (cons 'quit (sed-cmd-q-code cmd))] + ;; Q: quit without output + [(sed-cmd-Q? cmd) + (cons 'quit (sed-cmd-Q-code cmd))] + ;; n: output and read next + [(sed-cmd-n? cmd) + (unless (sed-state-suppress? state) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (flush-append-queue! state out-port) + (cons 'read-next pc)] + ;; N: append next line + [(sed-cmd-N? cmd) + (cons 'append-next pc)] + ;; h H g G x + [(sed-cmd-h? cmd) + (sed-state-hold-space-set! state (sed-state-pattern-space state)) + 'continue] + [(sed-cmd-H? cmd) + (sed-state-hold-space-set! state + (string-append (sed-state-hold-space state) "\n" + (sed-state-pattern-space state))) + 'continue] + [(sed-cmd-g? cmd) + (sed-state-pattern-space-set! state (sed-state-hold-space state)) + 'continue] + [(sed-cmd-G? cmd) + (sed-state-pattern-space-set! state + (string-append (sed-state-pattern-space state) "\n" + (sed-state-hold-space state))) + 'continue] + [(sed-cmd-x? cmd) + (let ([tmp (sed-state-pattern-space state)]) + (sed-state-pattern-space-set! state (sed-state-hold-space state)) + (sed-state-hold-space-set! state tmp)) + 'continue] + ;; l + [(sed-cmd-l? cmd) + (do-l-cmd! state (sed-cmd-l-width cmd) out-port) + 'continue] + ;; = + [(sed-cmd-=? cmd) + (put-string out-port (number->string (sed-state-line-num state))) + (newline out-port) + 'continue] + ;; z + [(sed-cmd-z? cmd) + (sed-state-pattern-space-set! state "") + 'continue] + ;; F + [(sed-cmd-F? cmd) + (put-string out-port (sed-state-filename state)) + (newline out-port) + 'continue] + ;; a + [(sed-cmd-a? cmd) + (sed-state-append-queue-set! state + (append (sed-state-append-queue state) + (list (sed-cmd-a-text cmd)))) + 'continue] + ;; i + [(sed-cmd-i? cmd) + (put-string out-port (sed-cmd-i-text cmd)) + (newline out-port) + 'continue] + ;; c + [(sed-cmd-c? cmd) + (let ([is-range? (sed-range-addr? (cmd-addr cmd))] + [is-last? (range-last-line? (cmd-addr cmd) pc rs)]) + (if (and is-range? (not is-last?)) + 'delete + (begin + (put-string out-port (sed-cmd-c-text cmd)) + (newline out-port) + 'delete)))] + ;; r + [(sed-cmd-r? cmd) + (unless (sed-state-sandbox? state) + (sed-state-append-queue-set! state + (append (sed-state-append-queue state) + (list (cons 'file (sed-cmd-r-filename cmd)))))) + 'continue] + ;; R + [(sed-cmd-R? cmd) + (unless (sed-state-sandbox? state) + (sed-state-append-queue-set! state + (append (sed-state-append-queue state) + (list (cons 'file-line (sed-cmd-R-filename cmd)))))) + 'continue] + ;; w + [(sed-cmd-w? cmd) + (write-to-file! state (sed-cmd-w-filename cmd) + (sed-state-pattern-space state)) + 'continue] + ;; W + [(sed-cmd-W? cmd) + (let* ([ps (sed-state-pattern-space state)] + [nl (string-index-char ps #\newline)]) + (write-to-file! state (sed-cmd-W-filename cmd) + (if nl (substring ps 0 nl) ps))) + 'continue] + ;; e + [(sed-cmd-e? cmd) + (unless (sed-state-sandbox? state) + (if (sed-cmd-e-cmd cmd) + (let ([out (exec-shell! (sed-cmd-e-cmd cmd))]) + (put-string out-port out) + (unless (or (string=? out "") + (char=? (string-ref out (fx- (string-length out) 1)) #\newline)) + (newline out-port))) + (sed-state-pattern-space-set! state + (exec-shell! (sed-state-pattern-space state))))) + 'continue] + ;; b: branch + [(sed-cmd-b? cmd) + (let ([label (sed-cmd-b-label cmd)]) + (if (string=? label "") + 'end-cycle + (let ([target (hashtable-ref labels label #f)]) + (if target (cons 'branch target) 'end-cycle))))] + ;; t: branch if sub succeeded + [(sed-cmd-t? cmd) + (if (sed-state-sub-succeeded? state) + (begin + (sed-state-sub-succeeded?-set! state #f) + (let ([label (sed-cmd-t-label cmd)]) + (if (string=? label "") + 'end-cycle + (let ([target (hashtable-ref labels label #f)]) + (if target (cons 'branch target) 'end-cycle))))) + 'continue)] + ;; T: branch if sub NOT succeeded + [(sed-cmd-T? cmd) + (if (not (sed-state-sub-succeeded? state)) + (let ([label (sed-cmd-T-label cmd)]) + (if (string=? label "") + 'end-cycle + (let ([target (hashtable-ref labels label #f)]) + (if target (cons 'branch target) 'end-cycle)))) + 'continue)] + ;; s + [(sed-cmd-s? cmd) + (when (do-substitute! state cmd pc rs) + (let ([flags (sed-cmd-s-flags cmd)]) + (when (sed-s-flags-print? flags) + (put-string out-port (sed-state-pattern-space state)) + (newline out-port)) + (when (sed-s-flags-write-file flags) + (write-to-file! state (sed-s-flags-write-file flags) + (sed-state-pattern-space state))) + (when (sed-s-flags-exec? flags) + (unless (sed-state-sandbox? state) + (sed-state-pattern-space-set! state + (exec-shell! (sed-state-pattern-space state))))))) + 'continue] + ;; y + [(sed-cmd-y? cmd) + (do-transliterate! state cmd) + 'continue] + ;; label: no-op + [(sed-cmd-label? cmd) 'continue] + [else 'continue])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/sed/parser.sls @@ -0,0 +1,488 @@ +#!chezscheme +;;; Sed script parser + +(library (sed parser) + (export parse-sed-script) + (import (chezscheme) (sed ast)) + + ;;; Parser state — use a vector for fast mutable access + ;; Slots: 0=script 1=pos 2=len 3=extended? + (define (make-parser script extended?) + (let ([v (make-vector 4)]) + (vector-set! v 0 script) + (vector-set! v 1 0) + (vector-set! v 2 (string-length script)) + (vector-set! v 3 extended?) + v)) + + (define-syntax p-script (syntax-rules () [(_ p) (vector-ref p 0)])) + (define-syntax p-pos (syntax-rules () [(_ p) (vector-ref p 1)])) + (define-syntax p-len (syntax-rules () [(_ p) (vector-ref p 2)])) + + (define-syntax p-pos-set! + (syntax-rules () [(_ p v) (vector-set! p 1 v)])) + + (define (p-ch p) + (let ([i (p-pos p)]) + (if (fx< i (p-len p)) + (string-ref (p-script p) i) + #f))) + + (define (p-ch+ p offset) + (let ([i (fx+ (p-pos p) offset)]) + (if (fx< i (p-len p)) + (string-ref (p-script p) i) + #f))) + + (define (p-advance! p) + (let ([i (p-pos p)]) + (when (fx< i (p-len p)) + (p-pos-set! p (fx+ i 1))))) + + (define (p-peek p) (p-ch p)) + (define (p-eof? p) (fx>= (p-pos p) (p-len p))) + + (define (p-skip-blanks! p) + (let loop () + (let ([c (p-ch p)]) + (when (and c (or (char=? c #\space) (char=? c #\tab))) + (p-advance! p) + (loop))))) + + (define (p-skip-whitespace-and-semicolons! p) + (let loop () + (let ([c (p-ch p)])