build: convert raw-Chez .sls library source to src/ .ss with generated .sls wrappers
ober
3603246c0dce1889de4ee43ad73cd1305799a95f
--- a/.gitignore +++ b/.gitignore @@ -10,3 +10,6 @@ jsed .jsed-test-file .jsed-test-file.bak .jsed-test-script.sed + +# Generated .sls wrappers from src/ .ss source +lib/**/*.sls --- a/Makefile +++ b/Makefile @@ -24,8 +24,11 @@ TARGET_EVIDENCE_DIR ?= dist/target-evidence all: binary -# Standalone native binary via .jerbuild (entry main.ss -> jsed). -binary: +# Generate R6RS .sls wrappers from src/ .ss source. +transpile: + python3 support/wrap-ss-to-sls.py src lib + +binary: transpile $(JERBUILD) build build: binary deleted file mode 100644 --- a/lib/sed/ast.sls +++ /dev/null @@ -1,159 +0,0 @@ -#!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 (scheme)) - - ;;; 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 deleted file mode 100644 --- a/lib/sed/engine.sls +++ /dev/null @@ -1,854 +0,0 @@ -#!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! - close-open-write-files!) - (import (except (scheme) compile-program) - (only (std os env) getenv) - (only (std security taint) check-untainted!) - (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=?))) - - (define (truthy-env? name) - (let ([value (getenv name)]) - (and value - (or (string=? value "1") - (string-ci=? value "true") - (string-ci=? value "yes"))))) - - (define (sed-shell-enabled?) - (truthy-env? "JSED_ALLOW_SHELL")) - - (define (sed-script-file-io-enabled? state) - (and (not (sed-state-sandbox? state)) - (truthy-env? "JSED_ALLOW_SCRIPT_FILE_IO"))) - - (define (string-contains-nul? s) - (let ([len (string-length s)]) - (let loop ([i 0]) - (and (< i len) - (or (char=? (string-ref s i) (integer->char 0)) - (loop (+ i 1))))))) - - (define (check-sed-path! who filename) - (unless (and (string? filename) (> (string-length filename) 0)) - (error who "path must be a non-empty string" filename)) - (when (string-contains-nul? filename) - (error who "path contains NUL byte" filename)) - (check-untainted! filename who) - filename) - - (define (check-sed-command! cmd) - (unless (and (string? cmd) (> (string-length cmd) 0)) - (error 'sed-shell "command must be a non-empty string" cmd)) - (when (string-contains-nul? cmd) - (error 'sed-shell "command contains NUL byte" cmd)) - (check-untainted! cmd 'sed-shell) - cmd) - - ;;; Compiled program - (define-record-type sed-program (fields cmds labels)) - - (define default-max-compiled-commands 65536) - - (define max-compiled-commands - (let ([value (getenv "JSED_MAX_COMMANDS")]) - (if value - (let ([n (string->number value)]) - (if (and n (integer? n) (> n 0) (<= n 1000000)) - n - default-max-compiled-commands)) - default-max-compiled-commands))) - - ;; Count every parsed node, including labels and block containers, before - ;; allocating the instruction buffer. Labels do not emit an instruction but - ;; must still consume the parser/compile resource budget. - (define (checked-command-count cmds) - (letrec ([count-list - (lambda (rest total) - (if (null? rest) - total - (let* ([cmd (car rest)] - [with-node (+ total 1)]) - (when (> with-node max-compiled-commands) - (error 'compile-program - "compiled command count exceeds configured limit" - with-node max-compiled-commands)) - (let ([with-children - (if (sed-cmd-block? cmd) - (count-list (sed-cmd-block-cmds cmd) with-node) - with-node)]) - (count-list (cdr rest) with-children)))))]) - (count-list cmds 0))) - - ;;; Compile tree -> flat vector - (define (compile-program cmds) - (let* ([command-count (checked-command-count cmds)] - ;; One slot is convenient for an empty program; only the first PC - ;; entries are returned below. - [buf (make-vector (if (= command-count 0) 1 command-count) #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))) - - (define (with-compiled-rx pattern icase? multiline? extended? proc) - (let ([rx (compile-rx pattern icase? multiline? extended?)]) - (dynamic-wind - (lambda () #t) - (lambda () (proc rx)) - (lambda () (pcre2-free rx))))) - - ;;; 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) - (with-compiled-rx (sed-addr-regex-pattern addr) - (sed-addr-regex-icase addr) #f - (sed-state-extended? state) - (lambda (rx) - (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-zero? - (and (sed-addr-line? start) (fx= 0 (sed-addr-line-n start)))] - [start-m? - (if start-zero? - (fx<= (sed-state-line-num state) 1) - (addr-primitive-matches? start state))]) - (when start-m? - (if (and (sed-addr-regex? end) (not start-zero?)) - (hashtable-set! range-states pc (cons #t #f)) - (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)] - [repl (sed-cmd-s-replacement cmd)] - [subject (sed-state-pattern-space state)]) - (with-compiled-rx (sed-cmd-s-pattern cmd) icase? mline? - (sed-state-extended? state) - (lambda (rx) - (let ([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 ([width (max 3 width)] - [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 "\\" - (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 (and (fx> col 0) (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) - (when (sed-script-file-io-enabled? state) - (let* ([filename (check-sed-path! 'sed-script-file filename)] - [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 (close-open-write-files! state) - (let ([ht (sed-state-open-write-files state)]) - (let-values ([(keys vals) (hashtable-entries ht)]) - (let ([n (vector-length keys)]) - (let loop ([i 0]) - (when (< i n) - (guard (e [else (void)]) - (close-port (vector-ref vals i))) - (hashtable-delete! ht (vector-ref keys i)) - (loop (+ i 1)))))))) - - (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)) - (when (sed-script-file-io-enabled? state) - (let ([filename (check-sed-path! 'sed-script-file (cdr item))]) - (guard (e [else (void)]) - (call-with-input-file filename - (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)) - (when (sed-script-file-io-enabled? state) - (let ([filename (check-sed-path! 'sed-script-file (cdr item))]) - (guard (e [else (void)]) - (call-with-input-file filename - (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) - (if (not (sed-shell-enabled?)) - "" - (let ([cmd (check-sed-command! 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) - (when (sed-script-file-io-enabled? 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) - (when (sed-script-file-io-enabled? 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) - (when (and (not (sed-state-sandbox? state)) (sed-shell-enabled?)) - (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) - (error 'sed "can't find label for jump" label)))))] - ;; 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 "")