scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

updates from 0.5.2

This commit is contained in:
marting 1999-09-23 17:46:46 +00:00
parent 58f90e2359
commit 0f0fe9f2ff
19 changed files with 1069 additions and 450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

220
scsh/awk.scm
View File

@ -1,10 +1,26 @@
;;; An awk loop, after the design of David Albertz and Olin Shivers.
;;; Copyright (c) 1994 by Olin Shivers.
;;; This uses the new RX SRE syntax. Defines a Clinger-Rees expander for
;;; the old, pre-SRE syntax AWK, and one for the new SRE-syntax AWK.
;;; Imports:
;;; - Requires RECEIVE from RECEIVING package.
;;; - Would require DESTRUCTURE from DESTRUCTURING package, but it appears
;;; to be broken, so we hack it w/cars and cdrs.
;;; - Requires STRING-MATCH from SCSH package.
;;; - Requires STRING-MATCH and STRING-MATCH? from RE-EXPORTS package.
;;; - Requires regexp manipulation stuff from SRE-SYNTAX-TOOLS
;;; - Requires ERROR from ERROR-PACKAGE.
;;; - Requires ANY and FILTER frm SCSH-UTILITIES.
;;;
;;; Needs error-package receiving sre-syntax-tools scsh-utilities
;;;
;;; Exports:
;;; (expand-awk exp r c) Clinger-Rees macro expander, new syntax
;;; (expand-awk/obsolete exp r c) Clinger-Rees macro expander, old syntax
;;;
;;; next-range next-:range These four functions are used in the
;;; next-range: next-:range: code output by the expander.
;;; This should be hacked to convert regexp strings into regexp structures
;;; at the top of the form, and then just refer to the structs in the
@ -19,13 +35,14 @@
;;;
;;; ;;; Count the number of non-comment lines of code in my Scheme source.
;;; (awk (read-line) (line) ((nlines 0))
;;; ("^[ \t]*;" nlines) ; A comment line.
;;; ((: bos (* white) ";") nlines) ; A comment line.
;;; (else (+ nlines 1))) ; Not a comment line.
;;;
;;; ;;; Read numbers, counting the evens and odds.
;;; ;;; Read numbers, counting the evens and odds,
;;; ;;; and printing out sign information.
;;; (awk (read) (val) ((evens 0) (odds 0))
;;; ((zero? val) (display "zero ") (values evens odds)) ; Tell me about
;;; ((> val 0) (display "pos ") (values evens odds)) ; sign, too.
;;; ((zero? val) (display "zero ") (values evens odds))
;;; ((> val 0) (display "pos ") (values evens odds))
;;; (else (display "neg ") (values evens odds))
;;;
;;; ((even? val) (values (+ evens 1) odds))
@ -37,6 +54,17 @@
;;; .
;;; .
;;; <clausen>)
;;;
;;; <clause> ::= (ELSE body ...)
;;; | (:RANGE test1 test2 body ...) ; RANGE :RANGE RANGE: :RANGE:
;;; | (AFTER body ...)
;;; | (test => proc)
;;; | (test ==> vars body ...)
;;; | (test body ...)
;;;
;;; test ::= integer | sre | (WHEN exp) | exp
;;; (sre/exp ambiguities resolved in favor of SRE)
;;; This macro is written using Clinger/Rees explicit-renaming low-level
;;; macros. So it is pretty ugly. It takes a little care to generate
@ -145,17 +173,23 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (expand-awk exp r c)
;;; If STRING-REGEXPS? is true, we use the old, obsolete syntax, where
;;; a test form that is a string, such as "shivers|bdc", is treated as
;;; a regular expression in the Posix string syntax. Otherwise, we use the
;;; new SRE syntax, where strings are treated as SRE constants.
(define (expand-awk exp r c) (really-expand-awk exp r c #f))
(define (expand-awk/obsolete exp r c) (really-expand-awk exp r c #t))
(define (really-expand-awk exp r c string-regexps?)
(let* ((%lambda (r 'lambda)) ; Bind a mess of keywords.
(%let (r 'let))
(%receive (r 'receive))
(%values (r 'values))
(%if (r 'if))
(%eof-object? (r 'eof-object?))
(%after (r 'after))
(%else (r 'else))
(%+ (r '+))
(%make-regexp (r 'make-regexp))
(%rx (r 'rx))
(gensym (let ((i 0))
(lambda (s)
@ -173,7 +207,9 @@
;; Rip the form apart.
(reader-exp (cadr exp))
(rec/field-vars (caddr exp))
;; Replace #F's with gensym'd variables in the record/field vars.
(rec/field-vars (map (lambda (v) (or v (r (gensym "anon-rfval"))))
(caddr exp)))
(rec-var (car rec/field-vars)) ; The var bound to the record.
(rest (cdddr exp))) ; Stuff after the rec&field-vars.
@ -182,10 +218,18 @@
(values #f (car rest) (cdr rest)) ; form.
(values (car rest) (cadr rest) (cddr rest)))
;; If we are doing the old, obsolete Posix-string syntax, map
;; the clause tests over to the new syntax.
(let* ((clauses (if string-regexps?
(map (lambda (clause)
(hack-clause-for-posix-string-syntax clause r c))
clauses)
clauses))
;; Some analysis: what have we got?
;; Range clauses, else clauses, line num tests,...
(let* ((recnum-tests? ; Do any of the clauses test the record
(any? (lambda (clause) ; count? (I.e., any integer tests?)
(recnum-tests? ; Do any of the clauses test the record
(any (lambda (clause) ; count? (I.e., any integer tests?)
(let ((test (car clause)))
(or (integer? test)
(and (range? clause)
@ -195,25 +239,25 @@
;; If any ELSE clauses, bind this to the var in which we
;; will keep the else state, otherwise #f.
(else-var (and (any? (lambda (clause)
(else-var (and (any (lambda (clause)
(c (car clause) %else))
clauses)
(r 'else)))
(r 'else-state)))
;; We compile all of the regexp patterns into regexp
;; We compile all of the *static* regexp patterns into regexp
;; data structures outside the AWK loop. So we need to
;; make a list of all the regexps that are used as tests.
(patterns (apply append
(map (lambda (clause)
(let ((test (car clause)))
(cond ((string? test) (list test))
(cond ((sre-form? test r c) (list test))
((range? clause)
(let ((t1 (cadr clause))
(t2 (caddr clause)))
(append (if (string? t1)
(append (if (sre-form? t1 r c)
(list t1)
'())
(if (string? t2)
(if (sre-form? t2 r c)
(list t2)
'()))))
(else '()))))
@ -227,16 +271,28 @@
(if (member pat ans) ans (cons pat ans)))
'())))
;; An alist matching regexp patterns with the vars to which
;; we will bind their compiled regexp data structure.
(pats/vars (map (lambda (p) (cons p (r (gensym "re."))))
(pats-static? (map (lambda (sre)
(static-regexp? (parse-sre sre r c)))
patterns))
;; A LET-list binding the regexp vars to their compiled regexps.
(regexp-inits (map (lambda (p/v)
`(,(cdr p/v) (,%make-regexp ,(car p/v))))
pats/vars))
;; An alist matching each pattern with the exp that refers
;; to it -- a var if it's static, a Scheme (RX ...) exp otw.
(pats/refs (map (lambda (pat static?)
(cons pat
(if static?
(r (gensym "re."))
`(,%rx ,pat))))
patterns pats-static?))
;; A LET-list binding the regexp vars to their
;; compiled static regexps.
(regexp-inits (apply append
(map (lambda (p/r static?)
(if static?
`((,(cdr p/r) (,%rx ,(car p/r))))
'()))
pats/refs
pats-static?)))
;; Make a list of state vars for the range clauses.
;; For each range clause, we need a boolean var to track
@ -283,7 +339,7 @@
(loop-body (awk-loop-body lp-var rec-var else-var
rec-counter range-vars svars
clauses pats/vars r c))
clauses pats/refs r c))
;; Variables that have to be updated per-iteration, as a LET list.
;; Note that we are careful not to increment the record counter
@ -306,12 +362,32 @@
`(,%if (,%eof-object? ,rec-var) ,after-exp
,loop-body))))))))
;;; This maps a clause in the old, obsolete syntax over to a clause
;;; in the new, SRE syntax.
(define (hack-clause-for-posix-string-syntax clause r c)
(let ((hack-simple-test (lambda (test)
(cond ((string? test)
`(,(r 'posix-string) ,test))
((integer? test) test)
(else `(,(r 'when) ,test)))))
(test (car clause)))
(cond ((range-keyword? test r c)
`(,test ,(hack-simple-test (cadr clause))
,(hack-simple-test (caddr clause))
. ,(cdddr clause)))
((or (c test (r 'else))
(c test (r 'after)))
clause)
(else `(,(hack-simple-test test) . ,(cdr clause))))))
;;; Expand into the body of the awk loop -- the code that tests & executes
;;; each clause, and then jumps to the top of the loop.
(define (awk-loop-body lp-var rec-var else-var rec-counter
range-vars svars clauses pats/vars r c)
range-vars svars clauses pats/refs r c)
(let ((clause-vars (if else-var (cons else-var svars) svars))
(loop-vars (append (if rec-counter (list rec-counter) '())
range-vars
@ -329,7 +405,7 @@
(let ((tail (expand (cdr clauses) (cdr range-vars))))
(expand-range-clause clause tail (car range-vars)
rec-var else-var rec-counter svars
pats/vars
pats/refs
r c)))
((c test %after) ; An AFTER clause. Skip it.
@ -343,7 +419,7 @@
(let ((tail (expand (cdr clauses) range-vars)))
(expand-simple-clause clause tail
rec-var else-var rec-counter svars
pats/vars r c)))))
pats/refs r c)))))
;; No clauses -- just jump to top of loop.
`(,lp-var . ,loop-vars)))))
@ -351,49 +427,92 @@
;;; Make a Scheme expression out of a test form.
;;; Integer i => (= i <record-counter>)
;;; String s => (regexp-exec s <record>)
;;; SRE s => (regexp-search <re> <record>)
;;; (when e) => e
;;; Expression e => e
;;;
;;; If FOR-VALUE? is true, then we do regexp searches with REGEXP-SEARCH,
;;; otherwise, we use the cheaper REGEXP-SEARCH?.
(define (->simple-clause-test test-form rec-var rec-counter pats/vars r)
(define (->simple-clause-test test-form for-value? rec-var rec-counter pats/refs r c)
(cond ((integer? test-form) `(,(r '=) ,rec-counter ,test-form))
((string? test-form)
(let ((re-var (cond ((assoc test-form pats/vars) => cdr)
(else (error "Impossible AWK error -- unknown regexp"
test-form pats/vars)))))
`(,(r 'regexp-exec) ,re-var ,rec-var)))
((sre-form? test-form r c)
`(,(r (if for-value? 'regexp-search 'regexp-search?))
,(cdr (assoc test-form pats/refs))
,rec-var))
((and (pair? test-form)
(c (r 'when) (car test-form)))
(if (= 2 (length test-form)) (cadr test-form)
(error "Illegal WHEN test in AWK" test-form)))
(else test-form)))
(define (expand-simple-clause clause tail
rec-var else-var rec-counter svars
pats/vars r c)
pats/refs r c)
(let* ((%let (r 'let))
(%= (r '=))
(%string-match (r 'string-match))
(%arrow (r '=>))
(%long-arrow (r '==>))
(%if (r 'if))
(%mss (r 'match:substring))
(test (car clause))
(test (->simple-clause-test test rec-var rec-counter pats/vars r))
(mktest (lambda (for-value?)
(->simple-clause-test test for-value? rec-var
rec-counter pats/refs r c)))
;; Is clause of the form (test => proc)
(arrow? (and (= 3 (length clause))
(c (cadr clause) %arrow)))
;; How about (test ==> (var ...) body ...)?
(long-arrow? (and (< 3 (length clause))
(c (cadr clause) %long-arrow)))
(null-clause-list (null-clause-action else-var svars r))
;; The core form conditionally executes the body.
;; It returns the new else var and the new state vars, if any.
(core (if arrow?
(core (cond (arrow?
(let* ((tv (r 'tval)) ; APP is the actual
(app `(,(caddr clause) ,tv))) ; body: (proc tv).
(app `(,(caddr clause) ,tv)) ; body: (proc tv).
(test (mktest #t)))
`(,%let ((,tv ,test))
(,%if ,tv
,(clause-action (list app) else-var svars r c)
. ,null-clause-list)))
. ,null-clause-list))))
`(,%if ,test ,(clause-action (cdr clause) else-var svars r c)
. ,null-clause-list)))
(long-arrow?
(let* ((tv (r 'tval))
(test (mktest #t))
(bindings ; List of LET bindings for submatches.
(let lp ((i 0)
(vars (caddr clause))
(bindings '()))
(if (pair? vars)
(let ((var (car vars)))
(lp (+ i 1) (cdr vars)
(if var
`((,var (,%mss ,tv ,i)) . ,bindings)
bindings))) ; #F = "don't-care"
bindings))))
`(,%let ((,tv ,test))
(,%if ,tv
(,%let ,bindings ; Bind submatches.
. ,(deblock (clause-action (cdddr clause)
else-var svars
r c)
r c))
. ,null-clause-list))))
(else
`(,%if ,(mktest #f) ,(clause-action (cdr clause)
else-var svars r c)
. ,null-clause-list))))
(loop-vars (if else-var (cons else-var svars) svars)))
@ -406,7 +525,7 @@
(define (expand-range-clause clause tail range-var
rec-var else-var rec-counter svars
pats/vars r c)
pats/refs r c)
(let* ((start-test (cadr clause))
(stop-test (caddr clause))
(body (cdddr clause))
@ -423,10 +542,10 @@
(else (error "Unrecognised range keyword!" clause)))))
;; Convert the start and stop test forms to code.
(start-test (->simple-clause-test start-test rec-var
rec-counter pats/vars r))
(stop-test (->simple-clause-test stop-test rec-var
rec-counter pats/vars r))
(start-test (->simple-clause-test start-test #f rec-var
rec-counter pats/refs r c))
(stop-test (->simple-clause-test stop-test #f rec-var
rec-counter pats/refs r c))
(start-thunk `(,%lambda () ,start-test)) ; ...and thunkate them.
(stop-thunk `(,%lambda () ,stop-test))
@ -448,7 +567,6 @@
(tail-exps (deblock tail r c))
(%if (r 'if))
(%receive (r 'receive))
(%let (r 'let))
;; We are hard-wiring the else var to #t after this, so the core

379
scsh/char-set.scm
View File

@ -1,17 +1,53 @@
;;; -*-Scheme-*-
;;;
;;; Character Sets package
;;; ported from MIT Scheme runtime
;;; - ported from MIT Scheme runtime
;;; by Brian D. Carlstrom
;;; Sleazy code.
;;; - Rehacked & extended by Olin Shivers 6/98.
;;; This is not great code. Char sets are represented as 256-char
;;; strings. If char i is ASCII 0, then it isn't in the set; if char i
;;; is ASCII 1, then it is in the set.
;;; - Should be rewritten to use bit strings, or at least byte vecs.
;;; - Is ASCII/Latin-1 specific. Would certainly have to be rewritten
;;; for Unicode.
;;; - The standard character sets are not Latin-1 compliant, just ASCII.
;;; This code uses jar's DEFINE-RECORD-TYPE macro to define the char-set
;;; record type, because the scsh-standard DEFINE-RECORD form automatically
;;; defines a COPY-FOO function, which is not the one we want, being a shallow
;;; copy of the record fields.
;;; New dfns:
;;; (char-set= cs1 cs2 ...)
;;; (char-set<= cs1 cs2 ...)
;;; (char-set-fold kons knil cs)
;;; (char-set-for-each f cs)
;;; (char-set-copy cs)
;;; (char-set-size cs)
;;; char-set:printing (char-printing? c)
;;; char-set:blank (char-blank? c)
;;; char-set:control (char-control? c)
;;; char-set:hex-digit (char-hex-digit? c)
;;; char-set:ascii (char-ascii? c)
;;; char-set:empty
;;; char-set:full
;;; char-set-every? pred cs
;;; char-set-any pred cs
;;; char-set-adjoin cset char -> cset
;;; char-set-adjoin! cset char -> cset
;;; char-set-delete cset char -> cset
;;; char-set-delete! cset char -> cset
(define char:newline (ascii->char 13))
(define char:tab (ascii->char 9))
(define char:linefeed (ascii->char 13))
(define char:vtab (ascii->char 11))
(define char:page (ascii->char 12))
(define char:return (ascii->char 10))
(define char:space (ascii->char 32))
(define (string-copy s) (substring s 0 (string-length s)))
(define (string-fill-range! str lower upper ch)
(do ((index lower (+ index 1)))
((>= index upper) str)
@ -23,42 +59,133 @@
;;;; Character Sets
(define (char-set? object)
(and (string? object)
(= (string-length object) 256)))
;(define-record char-set
; s) ; 256-char string; each char is either ASCII 0 or ASCII 1.
;;; Use jar's record macro.
(define-record-type char-set :char-set
(make-char-set s)
char-set?
(s char-set:s))
(define (char-set-copy cs) (make-char-set (string-copy (char-set:s cs))))
;;; The = and <= code is ugly because it's n-ary.
(define (char-set= cs1 . rest)
(let ((s1 (char-set:s cs1)))
(every (lambda (cs) (string=? s1 (char-set:s cs)))
rest)))
(define (char-set<= cs1 . rest)
(let lp ((s1 (char-set:s cs1))
(rest rest))
(or (not (pair? rest))
(let ((s2 (char-set:s (car rest)))
(rest (cdr rest)))
(let lp2 ((i 255))
(if (< i 0) (lp s2 rest)
(and (<= (char->ascii (string-ref s1 i))
(char->ascii (string-ref s2 i)))
(lp2 (- i 1)))))))))
(define (char-set-size cs)
(let ((s (char-set:s cs)))
(let lp ((i 255) (size 0))
(if (< i 0) size
(lp (- i 1)
(if (= 0 (char->ascii (string-ref s i))) size (+ size 1)))))))
(define (set-char-set cs in? . chars)
(let ((s (string-copy (char-set:s cs)))
(val (if in? (ascii->char 1) (ascii->char 0))))
(for-each (lambda (c) (string-set! s (char->ascii c) val))
chars)
(make-char-set s)))
(define (set-char-set! cs in? . chars)
(let ((s (char-set:s cs))
(val (if in? (ascii->char 1) (ascii->char 0))))
(for-each (lambda (c) (string-set! s (char->ascii c) val))
chars))
cs)
(define (char-set-adjoin cs . chars) (apply set-char-set cs #t chars))
(define (char-set-adjoin! cs . chars) (apply set-char-set! cs #t chars))
(define (char-set-delete cs . chars) (apply set-char-set cs #f chars))
(define (char-set-delete! cs . chars) (apply set-char-set! cs #f chars))
(define (char-set-for-each proc cs)
(let ((s (char-set:s cs)))
(let lp ((i 255))
(cond ((>= i 0)
(if (not (= 0 (char->ascii (string-ref s i))))
(proc (ascii->char i)))
(lp (- i 1)))))))
(define (char-set-fold kons knil cs)
(let ((s (char-set:s cs)))
(let lp ((i 255) (ans knil))
(if (< i 0) ans
(lp (- i 1)
(if (= 0 (char->ascii (string-ref s i)))
ans
(kons (ascii->char i) ans)))))))
(define reduce-char-set (deprecated-proc char-set-fold 'char-set-fold
"Use char-set-fold instead."))
(define (char-set-every? pred cs)
(let ((s (char-set:s cs)))
(let lp ((i 255))
(or (< i 0)
(if (= 0 (char->ascii (string-ref s i)))
(lp (- i 1))
(and (pred (ascii->char i))
(lp (- i 1))))))))
(define (char-set-any pred cs)
(let ((s (char-set:s cs)))
(let lp ((i 255))
(and (>= i 0)
(if (= 0 (char->ascii (string-ref s i)))
(lp (- i 1))
(or (pred (ascii->char i))
(lp (- i 1))))))))
(define (char-set . chars)
(chars->char-set chars))
(define (chars->char-set chars)
(let ((char-set (make-string 256 (ascii->char 0))))
(let ((s (make-string 256 (ascii->char 0))))
(for-each (lambda (char)
(string-set! char-set (char->ascii char) (ascii->char 1)))
(string-set! s (char->ascii char) (ascii->char 1)))
chars)
char-set))
(make-char-set s)))
(define (string->char-set str)
(let ((char-set (make-string 256 (ascii->char 0))))
(let ((s (make-string 256 (ascii->char 0))))
(do ((i (- (string-length str) 1) (- i 1)))
((< i 0) char-set)
(string-set! char-set (char->ascii (string-ref str i))
((< i 0) (make-char-set s))
(string-set! s (char->ascii (string-ref str i))
(ascii->char 1)))))
(define (ascii-range->char-set lower upper)
(let ((char-set (make-string 256 (ascii->char 0))))
(string-fill-range! char-set lower upper (ascii->char 1))
char-set))
(let ((s (make-string 256 (ascii->char 0))))
(string-fill-range! s lower upper (ascii->char 1))
(make-char-set s)))
(define (predicate->char-set predicate)
(let ((char-set (make-string 256)))
(let loop ((code 0))
(if (< code 256)
(begin (string-set! char-set code
(if (predicate (ascii->char code))
(let ((s (make-string 256)))
(let lp ((i 255))
(if (>= i 0)
(begin (string-set! s i (if (predicate (ascii->char i))
(ascii->char 1)
(ascii->char 0)))
(loop (+ 1 code)))))
char-set))
(lp (- i 1)))))
(make-char-set s)))
;;; {string, char, char-set, char predicate} -> char-set
@ -74,12 +201,13 @@
;;;-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
(define (char-set-members char-set)
(define (loop code)
(cond ((>= code 256) '())
((zero? (char->ascii (string-ref char-set code))) (loop (+ 1 code)))
(else (cons (ascii->char code) (loop (+ 1 code))))))
(loop 0))
(define (char-set-members cs)
(let ((s (char-set:s cs)))
(let lp ((i 255) (ans '()))
(if (< i 0) ans
(lp (- i 1)
(if (zero? (char->ascii (string-ref s i))) ans
(cons (ascii->char i) ans)))))))
;;; De-releasing CHAR-SET-MEMBER?
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -90,108 +218,131 @@
;;; break code. I ended up just choosing a new proc name that consistent with
;;; its arg order -- (CHAR-SET-CONTAINS? cset char).
(define (char-set-contains? char-set char)
(not (zero? (char->ascii (string-ref char-set (char->ascii char))))))
(define (char-set-contains? cs char)
(not (zero? (char->ascii (string-ref (char-set:s cs)
(char->ascii char))))))
;;; This actually isn't exported. Just CYA.
(define (char-set-member? . args)
(error "CHAR-SET-MEMBER? is no longer provided. Use CHAR-SET-CONTAINS? instead."))
(define (char-set-invert char-set)
(predicate->char-set
(lambda (char) (not (char-set-contains? char-set char)))))
(define (char-set-union char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(or (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
;;; Set algebra
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (char-set-invert cs)
(predicate->char-set (lambda (char)
(not (char-set-contains? cs char)))))
(define (char-set-union . csets)
(if (pair? csets)
(apply char-set-union! (char-set-copy (car csets)) (cdr csets))
char-set:empty))
(define (char-set-intersection . csets)
(if (pair? csets)
(apply char-set-intersection! (char-set-copy (car csets)) (cdr csets))
char-set:full))
(define (char-set-difference cs1 . csets)
(if (pair? csets)
(apply char-set-difference! (char-set-copy cs1) csets)
cs1))
;;; Linear set-algebraic ops
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; These guys are allowed, but not required, to side-effect their first
;;; argument when computing their result. In other words, you must use them
;;; as if they were completely functional, just like their non-! counterparts,
;;; and you must additionally ensure that their first arguments are "dead"
;;; at the point of call. In return, we promise a more efficient result, plus
;;; allowing you to always assume char-sets are unchangeable values.
;;; Apply P to each index and it's char in S: (P I C).
;;; Used by the intersection & difference.
(define (string-iter p s)
(let lp ((i (- (string-length s) 1)))
(cond ((>= i 0)
(p i (string-ref s i))
(lp (- i 1))))))
(define (char-set-invert! cset)
(let ((s (char-set:s cset)))
(string-iter (lambda (i c)
(string-set! s i (ascii->char (- 1 (char->ascii c)))))
s))
cset)
(define (char-set-union! cset1 . csets)
(let ((s (char-set:s cset1)))
(for-each (lambda (cset)
(char-set-for-each (lambda (c)
(string-set! s (char->ascii c)
(ascii->char 1)))
cset))
csets))
cset1)
(define (char-set-intersection! cset1 . csets)
(let ((s (char-set:s cset1)))
(for-each (lambda (cset)
(string-iter (lambda (i c)
(if (zero? (char->ascii c))
(string-set! s i (ascii->char 0))))
(char-set:s cset)))
csets))
cset1)
(define (char-set-difference! cset1 . csets)
(let ((s (char-set:s cset1)))
(for-each (lambda (cset)
(char-set-for-each (lambda (c)
(string-set! s (char->ascii c)
(ascii->char 0)))
cset))
csets))
cset1)
(define (char-set-intersection char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(char-set-contains? char-set-2 char)))))
(define (char-set-difference char-set-1 char-set-2)
(predicate->char-set
(lambda (char)
(and (char-set-contains? char-set-1 char)
(not (char-set-contains? char-set-2 char))))))
;;;; System Character Sets
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define char-set:upper-case (ascii-range->char-set #x41 #x5B))
(define char-set:lower-case (ascii-range->char-set #x61 #x7B))
(define char-set:numeric (ascii-range->char-set #x30 #x3A))
(define char-set:graphic (ascii-range->char-set #x20 #x7F))
(define char-set:not-graphic (char-set-invert char-set:graphic))
(define char-set:whitespace
(char-set char:newline char:tab char:linefeed
char:page char:return char:space))
(define char-set:not-whitespace (char-set-invert char-set:whitespace))
(define char-set:upper-case (ascii-range->char-set #x41 #x5B))
(define char-set:alphabetic
(char-set-union char-set:upper-case char-set:lower-case))
(define char-set:numeric (ascii-range->char-set #x30 #x3A))
(define char-set:alphanumeric
(char-set-union char-set:alphabetic char-set:numeric))
(define char-set:standard
(char-set-union char-set:graphic (char-set char:newline)))
(define char-set:graphic (ascii-range->char-set #x21 #x7F))
(define char-set:printing (ascii-range->char-set #x20 #x7F))
(define char-set:whitespace (char-set char:tab char:newline char:vtab
char:page char:return char:space))
(define char-set:blank (char-set char:space char:tab))
(define char-set:control (char-set-union (ascii-range->char-set 0 32)
(char-set (ascii->char 127))))
(define char-set:punctuation
(string->char-set "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~"))
(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
(define char-set:ascii (ascii-range->char-set 0 128))
(define char-set:empty (char-set))
(define char-set:full (char-set-invert char-set:empty))
(define (char-upper-case? char)
(char-set-contains? char-set:upper-case char))
(define (char-lower-case? char)
(char-set-contains? char-set:lower-case char))
(define (char-numeric? char)
(char-set-contains? char-set:numeric char))
(define (char-graphic? char)
(char-set-contains? char-set:graphic char))
(define (char-whitespace? char)
(char-set-contains? char-set:whitespace char))
(define (char-alphabetic? char)
(char-set-contains? char-set:alphabetic char))
(define (char-alphanumeric? char)
(char-set-contains? char-set:alphanumeric char))
(define (char-standard? char)
(char-set-contains? char-set:standard char))
;;; Bullshit legalese
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;$Header: /home/flat/Dropbox/Hacks/scsh/scsh-cvs/scsh/scsh/Attic/char-set.scm,v 1.1 1999/09/14 13:32:00 marting Exp $
;Copyright (c) 1988 Massachusetts Institute of Technology
;This material was developed by the Scheme project at the Massachusetts
;Institute of Technology, Department of Electrical Engineering and
;Computer Science. Permission to copy this software, to redistribute
;it, and to use it for any purpose is granted, subject to the following
;restrictions and understandings.
;1. Any copy made of this software must include this copyright notice
;in full.
;2. Users of this software agree to make their best efforts (a) to
;return to the MIT Scheme project any improvements or extensions that
;they make, so that these may be included in future releases; and (b)
;to inform MIT of noteworthy uses of this software.
;3. All materials developed as a consequence of the use of this
;software shall duly acknowledge such use, in accordance with the usual
;standards of acknowledging credit in academic research.
;4. MIT has made no warrantee or representation that the operation of
;this software will be error-free, and MIT is under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;5. In conjunction with products arising from the use of this material,
;there shall be no use of the name of the Massachusetts Institute of
;Technology nor of any adaptation thereof in any advertising,
;promotional, or sales literature without prior written consent from
;MIT in each case.
(define (char-set->pred cs) (lambda (c) (char-set-contains? cs c)))
(define char-lower-case? (char-set->pred char-set:lower-case))
(define char-upper-case? (char-set->pred char-set:upper-case))
(define char-alphabetic? (char-set->pred char-set:alphabetic))
(define char-numeric? (char-set->pred char-set:numeric))
(define char-alphanumeric? (char-set->pred char-set:alphanumeric))
(define char-graphic? (char-set->pred char-set:graphic))
(define char-printing? (char-set->pred char-set:printing))
(define char-whitespace? (char-set->pred char-set:whitespace))
(define char-blank? (char-set->pred char-set:blank))
(define char-control? (char-set->pred char-set:control))
(define char-punctuation? (char-set->pred char-set:punctuation))
(define char-hex-digit? (char-set->pred char-set:hex-digit))
(define char-ascii? (char-set->pred char-set:ascii))

61
scsh/defrec.scm
View File

@ -37,7 +37,7 @@
;;; (employee:sex emp)
;;; (employee:married? emp)
;;;
;;; - Setter procedures:
;;; - Field-setting procedures:
;;; (set-employee:name emp "Janet Q. Random")
;;; (set-employee:id emp 8271)
;;; (set-employee:salary emp 20000)
@ -45,6 +45,13 @@
;;; (set-employee:sex emp 'female)
;;; (set-employee:married? emp #t)
;;;
;;; - Field-modifier procedures:
;;; (modify-employee:salary emp (lambda (s) (* 1.03 s))) ; 3% raise
;;; ...similarly for other fields.
;;;
;;; - Record-copy procedure:
;;; (copy-employee emp) -> emp'
;;;
;;; - A type predicate:
;;; (employee? x)
;;;
@ -63,6 +70,9 @@
;;; will cause (make-ship 10 20 "Valdez") to print as
;;; #{ship "Valdez"}
;;; Dependencies:
;;; - Code produced by the macro needs the RECORDS package.
;;; - Macro-expander code needs ERROR-PACKAGE and RECEIVING
(define-syntax define-record
(lambda (form rename compare)
@ -100,6 +110,9 @@
(s-conc (s->s name) ":" (s->s field-name))))
(set-name (lambda (field-name)
(s-conc "set-" (s->s name) ":" (s->s field-name))))
(mod-name (lambda (field-name)
(s-conc "modify-" (s->s name) ":" (s->s field-name))))
(copy-name (s-conc "copy-" (s->s name)))
(pred-name (s-conc (s->s name) "?"))
(maker-name (s-conc "make-" (s->s name)))
(type-name (s-conc "type/" (s->s name)))
@ -149,16 +162,44 @@
(,%define ,pred-name (,%record-predicate ,type-name))
;; Accessors (EMPLOYEE:NAME emp), ...
,@(map (lambda (spec)
`(,%define ,(field-name (spec-name spec))
(,%record-accessor ,type-name ',(spec-name spec))))
field-specs)
,@(map (lambda (field)
`(,%define ,(field-name field)
(,%record-accessor ,type-name ',field)))
fields)
;; Setters (SET-EMPLOYEE:NAME emp name), ...
,@(map (lambda (spec)
`(,%define ,(set-name (spec-name spec))
(,%record-modifier ,type-name ',(spec-name spec))))
field-specs)
;; Field setters (SET-EMPLOYEE:NAME emp name), ...
,@(map (lambda (field)
`(,%define ,(set-name field)
(,%record-modifier ,type-name ',field)))
fields)
;; Field modifiers (MODIFY-EMPLOYEE:NAME emp proc), ...
,@(let ((%setter (rename 'setter)); set-ship:name
(%rec (rename 'r)) ; parameter: record to be modified.
(%proc (rename 'proc))) ; parameter: modifying procedure.
(map (lambda (field)
(let ((%setter-proc `(,%record-modifier ,type-name
',field))
(%sel-proc `(,%record-accessor ,type-name ',field))
(%selector (rename 'getter)))
`(,%define ,(mod-name field)
(,%let ((,%setter ,%setter-proc)
(,%selector ,%sel-proc))
(,%lambda (,%rec ,%proc)
(,%setter ,%rec (,%proc (,%selector ,%rec))))))))
fields))
;; Record copy procedure
,(let ((%rec (rename 'r))
(accessors (map (lambda (f) (rename (gensym "f"))) fields)))
`(,%define ,copy-name
(,%let ((,maker (,%record-constructor ,type-name ',fields))
. ,(map (lambda (field accessor)
`(,accessor (,%record-accessor ,type-name
',field)))
fields accessors))
(,%lambda (,%rec)
(,maker . ,(map (lambda (a) `(,a ,%rec)) accessors))))))
;; Methods (we only handle DISCLOSE methods).
,@(map (lambda (m)

8
scsh/endian.scm
View File

@ -33,7 +33,7 @@
(+ (arithmetic-shift byte1 8)
byte0))))
(define net-to-host-32 net-to-host-32-big)
(define net-to-host-16 net-to-host-16-big)
(define host-to-net-32 net-to-host-32-big)
(define host-to-net-16 net-to-host-16-big)
(define net-to-host-32 net-to-host-32-little)
(define net-to-host-16 net-to-host-16-little)
(define host-to-net-32 net-to-host-32-little)
(define host-to-net-16 net-to-host-16-little)

62
scsh/fileinfo.scm
View File

@ -3,11 +3,31 @@
;;; chase? true (the default) means if the file is a symlink, chase the link
;;; and report on the file it references. chase? = #f means check the actual
;;; file itself, even if it's a symlink.
;;; writeable means (1) file exists & is writeable OR (2) file doesn't exist
;;; but directory is writeable.
;;; (file-not-accessible? perms fd/port/fname)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; PERMS is 3 bits, not 9.
;;; writeable means (1) file exists & is writeable OR (2) file doesn't exist
;;; and directory is writeable. That is, writeable means writeable or
;;; creatable.
;;;
;;; There's a Posix call, access(), that checks using the *real* uid, not
;;; the effective uid, so that setuid programs can figure out if the luser
;;; has perms. file-not-accessible? is defined in terms of the effective uid,
;;; so we can't use access().
;;;
;;; This is a kind of bogus function. The only way to do a real check is to
;;; try an open() and see if it flies. Otherwise, there's an obvious atomicity
;;; problem. Also, we special case root, saying root always has all perms. But
;;; not even root can write on a read-only filesystem, such as a CD ROM. In
;;; this case, we'd blithely say the file was writeable -- there's no way to
;;; check for a ROFS without doing an open(). We need a euid analog to
;;; access(). Ah, well.
;;;
;;; I also should define a family of real uid perm-checking calls.
;;;
;;; Return values:
;;; #f Accessible
;;; #f Accessible in at least one of the requested ways.
;;; search-denied Can't stat
;;; permission File exists but is protected
;;; (also for errno/rofs)
@ -16,27 +36,43 @@
;;;
;;; Otherwise, signals an error.
(define (file-not-accessible? perms fd/port/fname . maybe-chase?)
(define (file-not-accessible? perms fd/port/fname)
(let ((uid (user-effective-uid)))
(and (not (zero? uid)) ; Root can do what he likes.
(with-errno-handler ((err data)
((errno/acces) 'search-denied)
((errno/noent) 'nonexistent)
((errno/notdir) 'not-directory))
((errno/notdir) 'not-directory)
(and (let* ((info (apply file-info fd/port/fname maybe-chase?))
;; If the file doesn't exist, we usually return
;; 'nonexistent, but we special-case writability
;; for the directory check.
((errno/noent)
(and (or (zero? (bitwise-and perms 2))
;; This string? test *has* to return #t.
;; If fd/port/fname is an fd or a port,
;; we wouldn't get an errno/noent error!
;; Just being paranoid...
(not (string? fd/port/fname))
;; OK, check to see if we can create
;; files in the directory.
(file-not-accessible? 2
(directory-as-file-name
(file-name-directory fd/port/fname))))
'nonexistent)))
(and (let* ((info (file-info fd/port/fname))
(acc (file-info:mode info)))
(cond ((= (file-info:uid info) (user-effective-uid)) ; User
(cond ((zero? uid) #f) ; Root can do as he wishes.
((= (file-info:uid info) (user-effective-uid)) ; User
(zero? (bitwise-and acc (arithmetic-shift perms 6))))
((= (file-info:gid info) (user-effective-gid)) ; Group
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
((memv (file-info:gid info) (user-supplementary-gids))
((or (= (file-info:gid info) (user-effective-gid)) ; Group
(memv (file-info:gid info) (user-supplementary-gids)))
(zero? (bitwise-and acc (arithmetic-shift perms 3))))
(else ; Other
(zero? (bitwise-and acc perms)))))
'permission)))))
'permission))))
;;;;;;

38
scsh/filemtch.scm
View File

@ -11,17 +11,28 @@
;;; root Search starts from here. Usefully "." (cwd)
;;; dots? => if true, dot files will be matched.
;;; if false, dot files will not be matched.
;;; pattern-list := a list of regular expressions or predicates
;;; Each member of the list corresponds
;;; to one or more levels in a directory.
;;; (A member with embedded "/" characters
;;; corresponds to multiple levels.)
;;; Example: ("foo" "bar" "\\.c$")
;;; pattern-list := a list of
;;; - strings
;;; These are split at /'s and then
;;; treated as Posix regexp strings.
;;; - regexps (typically made with RX macro)
;;; - predicates
;;; Each member of the list corresponds to one
;;; or more levels in a directory. (A string
;;; with embedded "/" characters corresponds
;;; to multiple levels.)
;;; Example:
;;; (file-match "." #f "foo" "bar" "\\.c$")
;;; means match files that end in ".c"
;;; if they reside in a directory with
;;; a name that contains "bar", which
;;; itself must reside in a directory
;;; with a name that contains "foo".
;;; Here are two more equivalent specs
;;; for the example above:
;;; (file-match "." #f "foo/bar/\\.c$")
;;; (file-match "." #f (rx "foo") (rx "bar")
;;; (rx ".c" eos))
;;; If a member in the list is a predicate,
;;; the predicate must be a procedure of
;;; one argument. This procedure is applied
@ -40,16 +51,19 @@
;;; when FILE-DIRECTORY? is applied to the bogus symlink.
(define (file-match root dot-files? . patterns)
(let ((patterns (apply append (map split-pat patterns))))
(let ((patterns (apply append
(map (lambda (p) (if (string? p)
(map posix-string->regexp (split-pat p))
p))
patterns))))
(let recur ((root root)
(patterns patterns))
(if (pair? patterns)
(let* ((pattern (car patterns))
(patterns (cdr patterns))
(dir (file-name-as-directory root))
(matcher (cond ((string? pattern)
(let ((re (make-regexp pattern)))
(lambda (f) (regexp-exec re f))))
(matcher (cond ((regexp? pattern)
(lambda (f) (regexp-search? re f)))
;; This arm makes a file-matcher using
;; predicate PATTERN. If PATTERN signals
@ -87,7 +101,7 @@
(if (procedure? pat) (list pat)
(let lp ((i (string-length pat))
(ans '()))
(cond ((rindex pat #\/ i) =>
(lambda (j) (lp (cons (substring pat (+ j 1) i) ans) j)))
(cond ((string-index-right pat #\/ i) =>
(lambda (j) (lp j (cons (substring pat (+ j 1) i) ans))))
(else
(cons (substring pat 0 i) ans))))))

30
scsh/fname.scm
View File

@ -68,7 +68,7 @@
;;; Returns FNAME's directory component in *directory form.*
(define (file-name-directory fname)
(cond ((rindex fname #\/) =>
(cond ((string-index-right fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname 0 (+ 1 rslash))
@ -77,7 +77,7 @@
(define (file-name-nondirectory fname)
(cond ((rindex fname #\/) =>
(cond ((string-index-right fname #\/) =>
(lambda (rslash)
(if (last-non-slash fname)
(substring fname (+ 1 rslash) (string-length fname))
@ -90,7 +90,7 @@
(len (string-length fname)))
(let split ((start 0))
(cond ((>= start len) '())
((index fname #\/ start) =>
((string-index fname #\/ start) =>
(lambda (slash)
(cons (substring fname start slash)
(split (+ slash 1)))))
@ -128,7 +128,7 @@
;;; /usr/shivers/.login are not considered extensions.
(define (file-name-extension-index fname)
(let ((dot (rindex fname #\.)))
(let ((dot (string-index-right fname #\.)))
(if (and dot
(> dot 0)
(not (char=? #\/ (string-ref fname (- dot 1)))))
@ -154,7 +154,7 @@
(let* ((user (substring fname 1 end))
(ui (name->user-info user)))
(user-info:home-dir ui))))))
(cond ((index fname #\/ 1) =>
(cond ((string-index fname #\/ 1) =>
(lambda (slash)
(string-append (tilde->homedir slash) "/"
(substring fname (+ slash 1) len))))
@ -163,9 +163,8 @@
(define (resolve-file-name fname . maybe-root)
(let* ((root (ensure-file-name-is-nondirectory (:optional maybe-root ".")))
(fname (ensure-file-name-is-nondirectory fname))
(len (string-length fname)))
(if (zero? len) "/"
(fname (ensure-file-name-is-nondirectory fname)))
(if (zero? (string-length fname)) "/"
(let ((c (string-ref fname 0)))
(cond ((char=? #\/ c) fname) ; Absolute file name.
@ -222,6 +221,15 @@
(simplify-file-name (apply resolve-file-name fname maybe-dir)))
(define (absolute-file-name fname . maybe-root)
(let ((fname (ensure-file-name-is-nondirectory fname)))
(if (zero? (string-length fname)) "/"
(simplify-file-name
(if (char=? #\/ (string-ref fname 0)) fname ; Absolute file name.
(let ((root (:optional maybe-root (cwd))))
(string-append (file-name-as-directory root) fname)))))))
(define (home-dir . maybe-user)
(if (pair? maybe-user)
(let ((user (car maybe-user)))
@ -248,7 +256,7 @@
(let ((len (string-length s)))
(cond
((zero? len) (apply string-append (reverse! ans)))
((index s #\$) =>
((string-index s #\$) =>
(lambda (i)
(let ((ans (cons (substring s 0 i) ans))
(s (substring s (+ i 1) len))
@ -256,13 +264,13 @@
(if (zero? len) (lp ans "")
(let ((next-char (string-ref s 0)))
(cond ((char=? #\{ next-char)
(cond ((index s #\}) =>
(cond ((string-index s #\}) =>
(lambda (i)
(lp (cons (getenv (substring s 1 i)) ans)
(substring s (+ i 1) len))))
(else (error "Unbalanced ${ delimiter in string" s))))
(else
(let ((i (or (index s #\/) len)))
(let ((i (or (string-index s #\/) len)))
(lp (cons (getenv (substring s 0 i)) ans)
(substring s i len))))))))))
(else (lp (cons s ans) ""))))))

68
scsh/fr.scm
View File

@ -1,5 +1,5 @@
;;; Field and record parsing utilities for scsh.
;;; Copyright (c) 1994 by Olin Shivers.
;;; Copyright (c) 1994 by Olin Shivers. See file COPYING.
;;; Notes:
;;; - Comment on the dependencies here...
@ -54,43 +54,12 @@
;;; This has the effect you want with field parsing. For example, if you split
;;; a string with the empty pattern, you will explode the string into its
;;; individual characters:
;;; ((suffix-splitter "") "foo") -> #("" "f" "o" "o")
;;; ((suffix-splitter (rx "")) "foo") -> #("" "f" "o" "o")
;;; However, even though this boundary case is handled correctly, we don't
;;; recommend using it. Say what you mean -- just use a field splitter:
;;; ((field-splitter ".") "foo") -> #("f" "o" "o")
;;; ((field-splitter (rx any)) "foo") -> #("f" "o" "o")
;;; (join-strings string-list [delimiter grammar]) => string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Paste strings together using the delimiter string.
;;;
;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
;;;
;;; DELIMITER defaults to a single space " "
;;; GRAMMAR is one of the symbols {infix, suffix} and defaults to 'infix.
;;; (join-strings strings [delim grammar])
(define (join-strings strings . args)
(if (pair? strings)
(let-optionals args ((delim " ") (grammar 'infix))
(check-arg string? delim join-strings)
(let ((strings (reverse strings)))
(let lp ((strings (cdr strings))
(ans (case grammar
((infix) (list (car strings)))
((suffix) (list (car strings) delim))
(else (error "Illegal grammar" grammar)))))
(if (pair? strings)
(lp (cdr strings)
(cons (car strings) (cons delim ans)))
; All done
(apply string-append ans)))))
"")) ; Special-cased for infix grammar.
;;; FIELD PARSERS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This section defines routines to split a string into fields.
@ -100,13 +69,13 @@
(define (->delim-matcher x)
(if (procedure? x) x ; matcher proc
(let ((re (cond ((regexp? x) x) ; regexp pattern
((string? x) (make-regexp x)) ; regexp string
(else (error "Illegal pattern/parser" x)))))
;; The matcher proc.
(let ((re (cond ((string? x) (re-string x))
((char-set? x) (re-char-set x))
((char? x) (re-string (string x)))
((regexp? x) x)
(else (error "Illegal field-reader delimiter value" x)))))
(lambda (s i)
(cond ((regexp-exec re s i) =>
(cond ((regexp-search re s i) =>
(lambda (m) (values (match:start m 0) (match:end m 0))))
(else (values #f #f)))))))
@ -154,7 +123,8 @@
match-delim cons-field
num-fields nfields-exact?))))))))
(define default-field-matcher (->delim-matcher "[^ \t\n]+"))
;;; Default field spec is runs of non-whitespace chars.
(define default-field-matcher (->delim-matcher (rx (+ (~ white)))))
;;; (field-splitter [field-spec num-fields])
@ -313,8 +283,8 @@
;;; Now, build the exported procedures: {infix,suffix,sloppy-suffix}-splitter.
(define default-suffix-matcher (->delim-matcher "[ \t\n]+|$"))
(define default-infix-matcher (->delim-matcher "[ \t\n]+"))
(define default-suffix-matcher (->delim-matcher (rx (| (+ white) eos))))
(define default-infix-matcher (->delim-matcher (rx (+ white))))
(define infix-splitter
(make-field-parser-generator default-infix-matcher infix-field-loop))
@ -408,21 +378,17 @@
;;; Repeatedly do (APPLY PROC M STATE) to generate new state values,
;;; where M is a regexp match structure made from matching against STRING.
;(define (regexp-reduce string start regexp proc . state)
; (let ((end (string-length string))
; (regexp (if (string? regexp)
; (make-regexp regexp)
; regexp)))
;
;(define (regexp-fold string start regexp proc . state)
; (let ((end (string-length string)))
; (let lp ((i start) (state state) (last-null? #f))
; (let ((j (if last-null? (+ i 1) i)))
; (cond ((and (<= j end) (regexp-exec regexp string j)) =>
; (cond ((and (<= j end) (regexp-search regexp string j)) =>
; (lambda (m)
; (receive state (apply proc m state)
; (lp (match:end m) state (= (match:start m) (match:end m))))))
; (else (apply values state)))))))
;
;(define (all-regexp-matches regexp string)
; (reverse (regexp-reduce string 0 regexp
; (reverse (regexp-fold string 0 regexp
; (lambda (m ans) (cons (match:substring m 0) ans))
; '())))

141
scsh/glob.scm
View File

@ -76,8 +76,8 @@
(else (let* ((dots? (char=? #\. (string-ref pat 0))) ; Match dot files?
(candidates (maybe-directory-files fname dots?))
(re (make-regexp (glob->regexp pat))))
(values (filter (lambda (f) (regexp-exec re f)) candidates)
(re (glob->regexp pat)))
(values (filter (lambda (f) (regexp-search? re f)) candidates)
#t))))) ; These guys exist for sure.
;;; The initial special-case above isn't really for the fast-path; it's
@ -87,64 +87,113 @@
;;; Translate a brace-free glob pattern to a regular expression.
(define (glob->regexp pat)
(let ((pat-len (string-length pat)))
(let lp ((result '(#\^))
(i 0)
(state 'normal))
(define glob->regexp
(let ((dot-star (re-repeat 0 #f re-any))) ; ".*" or (* any)
(lambda (pat)
(let ((pat-len (string-length pat))
(str-cons (lambda (chars res) ; Reverse CHARS and cons the
(if (pair? chars) ; result string-re onto RES.
(cons (re-string (list->string (reverse chars)))
res)
res))))
;; We accumulate chars into CHARS, and coalesce into a single string
;; with STR-CONS when we run across a non-char.
(let lp ((chars '())
(res (list re-bos))
(i 0))
(if (= i pat-len)
(if (eq? state 'normal)
(list->string (reverse (cons #\$ result)))
(error "Illegal glob pattern" pat))
(re-seq (reverse (str-cons chars res)))
(let ((c (string-ref pat i))
(i (+ i 1)))
(case state
((char-set)
(lp (cons c result)
i
(if (char=? c #\]) 'normal 'char-set)))
(case c
((#\\) (if (< i pat-len)
(lp (cons (string-ref pat i) chars)
res (+ i 1))
(error "Ill-formed glob pattern -- ends in backslash" pat)))
((escape)
(lp (case c
((#\$ #\^ #\. #\+ #\? #\* #\| #\( #\) #\[)
(cons c (cons #\\ result)))
(else (cons c result)))
i
'normal))
((#\*) (lp '()
(cons dot-star (str-cons chars res))
i))
((#\?) (lp '()
(cons re-any (str-cons chars res))
i))
;; Normal
(else (case c
((#\\) (lp result i 'escape))
((#\*) (lp (cons #\* (cons #\. result)) i 'normal))
((#\?) (lp (cons #\. result) i 'normal))
((#\[) (lp (cons c result) i 'char-set))
((#\$ #\^ #\. #\+ #\| #\( #\))
(lp (cons c (cons #\\ result)) i 'normal))
(else (lp (cons c result) i 'normal))))))))))
((#\[) (receive (cset i) (parse-glob-bracket pat i)
(lp '()
(cons (re-char-set cset)
(str-cons chars res))
i)))
(else (lp (cons c chars) res i))))))))))
;;; A glob bracket expression is [...] or [^...].
;;; The body is a sequence of <char> and <char>-<char> ranges.
;;; A <char> is any character except right-bracket, carat, hypen or backslash,
;;; or a backslash followed by any character at all.
(define (parse-glob-bracket pat i)
(let ((pat-len (string-length pat)))
(receive (negate? i) (if (and (< i pat-len) (char=? #\^ (string-ref pat i)))
(values #t (+ i 1))
(values #f i))
(let lp ((elts '()) (i i))
(if (>= i pat-len)
(error "Ill-formed glob pattern -- no terminating close-bracket" pat)
(let ((c (string-ref pat i))
(i (+ i 1)))
(case c
((#\])
(let ((cset (fold (lambda (elt cset)
(char-set-union
cset
(if (char? elt)
(char-set elt)
(ascii-range->char-set (char->ascii (car elt))
(+ 1 (char->ascii (cdr elt)))))))
char-set:empty
elts)))
(values (re-char-set (if negate?
(char-set-invert cset)
cset))
i)))
((#\\)
(if (>= i pat-len)
(error "Ill-formed glob pattern -- ends in backslash" pat)
(lp (cons (string-ref pat i) elts) (+ i 1))))
((#\-)
(cond ((>= i pat-len)
(error "Ill-formed glob pattern -- unterminated range." pat))
((or (null? elts) (not (char? (car elts))))
(error "Ill-formed glob pattern -- range has no beginning." pat))
(else (lp (cons (cons (car elts) (string-ref pat i)) elts)
(+ i 1)))))
(else (lp (cons c elts) i)))))))))
;;; Is the glob pattern free of *'s, ?'s and [...]'s?
(define (constant-glob? pattern)
(let ((patlen (string-length pattern)))
(let lp ((i 0)
(escape? #f)) ; Was last char an escape char (backslash)?
(if (= i patlen)
(if escape?
(error "Ill-formed glob pattern" pattern)
#t)
(let lp ((i 0))
(or (= i patlen)
(let ((next-i (+ i 1)))
(if escape? (lp next-i #f)
(case (string-ref pattern i)
((#\\) ; Escape char
(if (= next-i patlen)
(error "Ill-formed glob pattern -- ends in backslash"
pattern)
(lp (+ next-i 1))))
((#\* #\? #\[) #f)
((#\\) (lp next-i #t))
(else (lp next-i #f)))
; (lp next-i #f)))))))
))))))
(else (lp next-i))))))))
;;; Make an effort to get the files in the putative directory PATH.
;;; If PATH isn't a directory, or some filesys error happens (such

15
scsh/network.scm
View File

@ -47,8 +47,18 @@
(else
(error "socket-connect: unsupported protocol-family ~s"
protocol-family)))))
(connect-socket sock addr)
sock))
;; Close the socket and free the file-descriptors
;; if the connect fails:
(let ((connected #f))
(dynamic-wind
(lambda () #f)
(lambda () (connect-socket sock addr) (set! connected #t))
(lambda ()
(if (not connected)
(close-socket sock))))
(if connected
sock
#f))))
(define (bind-listen-accept-loop protocol-family proc arg)
(let* ((sock (create-socket protocol-family socket-type/stream))
@ -238,6 +248,7 @@
(define-foreign %listen/errno
(listen (integer sockfd) ; socket fdes
(integer backlog)) ; backlog
no-declare ; for Linux
(to-scheme integer errno_or_false))
(define-errno-syscall (%listen sockfd backlog) %listen/errno)

19
scsh/rdelim.scm
View File

@ -165,7 +165,8 @@
(error "Illegal START/END substring indices"
buf start end %read-delimited!))
(let ((delims (->char-set delims)))
(let* ((delims (->char-set delims))
(sdelims (char-set:s delims)))
(if (and (fdport? port) (not gobble?))
@ -173,7 +174,7 @@
(let lp ((start start) (total 0))
(let ((fd (fdport-data:fd (fdport-data port))))
(receive (terminator num-read)
(%read-delimited-fd!/errno delims buf
(%read-delimited-fd!/errno sdelims buf
fd start end)
(let ((total (+ num-read total)))
(cond ((not (integer? terminator)) (values terminator total))
@ -221,9 +222,11 @@
fixnum) ; number of chars skipped.
;;; JMG: I added scset here without knowing, what I do !!
(define (skip-char-set skip-chars . maybe-port)
(let ((port (:optional maybe-port (current-input-port)))
(cset (->char-set skip-chars)))
(let* ((port (:optional maybe-port (current-input-port)))
(cset (->char-set skip-chars))
(scset (char-set:s cset)))
(cond ((not (input-port? port))
(error "Illegal value -- not an input port." port))
@ -232,7 +235,7 @@
((fdport? port)
(let lp ((total 0))
(receive (err num-read) (%skip-char-set-fd/errno
cset (fdport-data:fd (fdport-data port)))
scset (fdport-data:fd (fdport-data port)))
(let ((total (+ total num-read)))
(cond ((not err) total)
((= errno/intr err) (lp total))
@ -263,7 +266,7 @@
;;; (read-paragraph [port handle-delim])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define blank-line-regexp (make-regexp "^[ \t]*\n$"))
(define blank-line-regexp (rx bos (* white) #\newline eos))
(define (read-paragraph . args)
(let-optionals args ((port (current-input-port))
@ -274,14 +277,14 @@
(cond ((eof-object? line)
(if (eq? handle-delim 'split) (values line line) line))
((regexp-exec blank-line-regexp line) (lp))
((regexp-search? blank-line-regexp line) (lp))
;; Then, read in non-blank lines.
(else
(let lp ((lines (list line)))
(let ((line (read-line port 'concat)))
(if (and (string? line)
(not (regexp-exec blank-line-regexp line)))
(not (regexp-search? blank-line-regexp line)))
(lp (cons line lines))

2
scsh/rx/re-low.scm
View File

@ -1,6 +1,8 @@
;;; Regular expression matching for scsh
;;; Copyright (c) 1994 by Olin Shivers.
(foreign-init-name "re_low")
(foreign-source
"/* Make sure foreign-function stubs interface to the C funs correctly: */"
"#include <sys/types.h>"

55
scsh/rx/re1.c
View File

@ -26,10 +26,11 @@
** and return a non-zero error code.
*/
int compile_re(scheme_value re_str, int sm_p, regex_t **cr)
int compile_re(s48_value re_str, int sm_p, regex_t **cr)
{
char *s = &STRING_REF(re_str, 0);
int len = STRING_LENGTH(re_str);
// JMG: char *s = &STRING_REF(re_str, 0);
char *s = s48_extract_string(re_str);
int len = S48_STRING_LENGTH(re_str);
int err;
regex_t *re = Alloc(regex_t);
@ -75,14 +76,15 @@ int compile_re(scheme_value re_str, int sm_p, regex_t **cr)
** Return 0 on success; #f if no match; non-zero integer error code otherwise.
*/
scheme_value re_search(const regex_t *re, scheme_value str, int start,
scheme_value trans_vec, int max_psm,
scheme_value start_vec, scheme_value end_vec)
s48_value re_search(const regex_t *re, s48_value str, int start,
s48_value trans_vec, int max_psm,
s48_value start_vec, s48_value end_vec)
{
char *s = &STRING_REF(str,0); /* Passed as a scheme_value because */
int len = STRING_LENGTH(str); /* it might contain nul bytes. */
// JMG: char *s = &STRING_REF(str,0); /* Passed as a s48_value because */
char *s = s48_extract_string(str);
int len = S48_STRING_LENGTH(str); /* it might contain nul bytes. */
int vlen = VECTOR_LENGTH(start_vec);
int vlen = S48_VECTOR_LENGTH(start_vec);
int retval;
regmatch_t static_pmatch[10], *pm;
@ -91,7 +93,7 @@ scheme_value re_search(const regex_t *re, scheme_value str, int start,
if( max_psm < 10 ) pm = static_pmatch;
else {
pm = Malloc(regmatch_t, max_psm+1);/* Add 1 for the whole-match info. */
if( !pm ) return ENTER_FIXNUM(-1);
if( !pm ) return s48_enter_fixnum(-1);
}
pm[0].rm_so = start;
@ -103,26 +105,31 @@ scheme_value re_search(const regex_t *re, scheme_value str, int start,
if( !retval && max_psm >= 0 ) {
int i;
VECTOR_REF(start_vec,0) = ENTER_FIXNUM(pm[0].rm_so); /* whole-match */
VECTOR_REF(end_vec,0) = ENTER_FIXNUM(pm[0].rm_eo);
//JMG: S48_VECTOR_REF(start_vec,0) = s48_enter_fixnum(pm[0].rm_so); /* whole-match */
//S48_VECTOR_REF(end_vec,0) = s48_enter_fixnum(pm[0].rm_eo);
S48_VECTOR_SET(start_vec,0, s48_enter_fixnum(pm[0].rm_so));
S48_VECTOR_SET(end_vec,0, s48_enter_fixnum(pm[0].rm_eo));
for( i=vlen-1; --i >= 0; ) { /* submatches */
scheme_value j_scm = VECTOR_REF(trans_vec,i);
if( j_scm != SCHFALSE ) {
int j = EXTRACT_FIXNUM(j_scm);
s48_value j_scm = S48_VECTOR_REF(trans_vec,i);
if( j_scm != S48_FALSE ) {
int j = s48_extract_fixnum(j_scm);
int k = pm[j].rm_so,
l = pm[j].rm_eo;
VECTOR_REF(start_vec,i+1) = (k != -1) ? ENTER_FIXNUM(k) : SCHFALSE;
VECTOR_REF(end_vec, i+1) = (l != -1) ? ENTER_FIXNUM(l) : SCHFALSE;
// JMG S48_VECTOR_REF(start_vec,i+1) = (k != -1) ? s48_enter_fixnum(k) : S48_FALSE;
//S48_VECTOR_REF(end_vec, i+1) = (l != -1) ? s48_enter_fixnum(l) : S48_FALSE;
S48_VECTOR_SET(start_vec,i+1, (k != -1) ? s48_enter_fixnum(k) : S48_FALSE);
S48_VECTOR_SET(end_vec, i+1, (l != -1) ? s48_enter_fixnum(l) : S48_FALSE);
}
}
}
if( max_psm >= 10 ) Free(pm);
if( retval==REG_NOMATCH ) return SCHFALSE;
if( ! retval ) return SCHTRUE;
return ENTER_FIXNUM(retval);
if( retval==REG_NOMATCH ) return S48_FALSE;
if( ! retval ) return S48_TRUE;
return s48_enter_fixnum(retval);
}
@ -133,10 +140,12 @@ scheme_value re_search(const regex_t *re, scheme_value str, int start,
** Put the number of survivors in nummatch.
*/
int filter_stringvec(scheme_value re_str, char const **stringvec)
int filter_stringvec(s48_value re_str, char const **stringvec)
{
int re_len = STRING_LENGTH(re_str);/* Passed as a scheme_value because */
char *re_chars = &STRING_REF(re_str,0);/* it might contain nul bytes. */
int re_len = S48_STRING_LENGTH(re_str);/* Passed as a s48_value because */
//JMG: char *re_chars = &STRING_REF(re_str,0);/* it might contain nul bytes. */
char *re_chars = s48_extract_string (re_str);/* it might contain nul bytes. */
regex_t re;
char const **p, **q;

10
scsh/rx/re1.h
View File

@ -1,13 +1,13 @@
/* Exports from re1.c */
int compile_re(scheme_value sre, int sm_p, regex_t **cr);
int compile_re(s48_value sre, int sm_p, regex_t **cr);
scheme_value re_search(const regex_t *re, scheme_value str, int start,
scheme_value trans_vec, int max_psm,
scheme_value start_vec, scheme_value end_vec);
s48_value re_search(const regex_t *re, s48_value str, int start,
s48_value trans_vec, int max_psm,
s48_value start_vec, s48_value end_vec);
/* Filter a vector of strings by a regexp. */
int filter_stringvec(scheme_value re_str, char const **stringvec);
int filter_stringvec(s48_value re_str, char const **stringvec);
/* Error code -> error msg */
const char *re_errint2str(int errcode, const regex_t *re);

102
scsh/scsh-interfaces.scm
View File

@ -208,7 +208,7 @@
port->sexp-list
port->string-list
port->list
reduce-port
port-fold reduce-port
port->fdes
read-string
read-string!
@ -283,7 +283,7 @@
directory-files
glob
glob-quote
file-match
; file-match
create-temp-file
temp-file-iterate
@ -418,6 +418,7 @@
exec-path-list))
;;; Kill me?
(define-interface scsh-regexp-interface
(export string-match
regexp-match?
@ -425,15 +426,18 @@
match:end
match:substring
make-regexp
->regexp
regexp?
regexp-exec
regexp-search
regexp-substitute
regexp-substitute/global
regexp-quote))
(define-interface scsh-string-interface
(export substitute-env-vars index rindex))
(export substitute-env-vars
;string-index string-index-right ; Now in string-lib
))
(define-interface scsh-file-names-interface
(export file-name-as-directory
@ -453,6 +457,7 @@
simplify-file-name
resolve-tilde-file-name
resolve-file-name
absolute-file-name
home-dir
home-file))
@ -485,6 +490,18 @@
set-date:week-day
set-date:year-day
modify-date:seconds
modify-date:minute
modify-date:hour
modify-date:month-day
modify-date:month
modify-date:year
modify-date:tz-name
modify-date:tz-secs
modify-date:summer?
modify-date:week-day
modify-date:year-day
time+ticks
ticks/sec
time
@ -553,13 +570,15 @@
(define-interface scsh-utilities-interface
(export del delete index rindex reduce filter first any first? nth
any? every? mapv mapv! vector-every? copy-vector initialize-vector
(export del delete filter first first? nth
fold fold-right
any every
mapv mapv! vector-every? copy-vector initialize-vector vector-append
vfold vfold-right
check-arg conjoin disjoin negate compose reverse! call/cc
deprecated-proc
deposit-bit-field
real->exact-integer
string-replace! substring-replace!))
real->exact-integer))
;;; semi-standard network magic numbers
;;; should be available on all platforms
@ -665,9 +684,19 @@
(define-interface char-set-interface
(export char:newline char:tab char:linefeed char:page char:return char:space
(export char:newline char:tab char:page char:return char:space char:vtab
char-ascii?
char-set?
char-set-copy
char-set=
char-set<=
char-set-size
char-set-adjoin char-set-delete
char-set-adjoin! char-set-delete!
char-set-for-each
char-set-fold reduce-char-set
char-set
chars->char-set
@ -679,27 +708,53 @@
char-set-members
char-set-contains?
char-set-every?
char-set-any
char-set-invert
char-set-union
char-set-intersection
char-set-difference
char-set:upper-case
char-set-invert!
char-set-union!
char-set-intersection!
char-set-difference!
char-set:lower-case
char-set:numeric
char-set:whitespace
char-set:not-whitespace
char-set:upper-case
char-set:alphabetic
char-set:numeric
char-set:alphanumeric
char-set:graphic
char-set:printing
char-set:whitespace
char-set:blank
char-set:control
char-set:punctuation
char-set:hex-digit
char-set:ascii
char-set:empty
char-set:full
char-upper-case?
char-lower-case?
char-numeric?
char-whitespace?
char-upper-case?
char-alphabetic?
char-numeric?
char-alphanumeric?
char-graphic?))
char-graphic?
char-printing?
char-whitespace?
char-blank?
char-control?
char-punctuation?
char-hex-digit?
char-ascii?
;; This is not properly part of the interface,
;; and should be moved to an internals interface --
;; it is used by rdelim.scm code.
char-set:s))
(define-interface scsh-field-reader-interface
@ -717,7 +772,8 @@
skip-char-set))
(define-interface awk-interface
(export (awk :syntax)))
(export (awk :syntax)
(awk/posix-string :syntax)))
(define-interface scsh-dbm-interface
(export dbm-open
@ -956,6 +1012,16 @@
tty-info:min set-tty-info:min
tty-info:time set-tty-info:time
modify-tty-info:control-chars
modify-tty-info:input-flags
modify-tty-info:output-flags
modify-tty-info:control-flags
modify-tty-info:local-flags
modify-tty-info:input-speed
modify-tty-info:output-speed
modify-tty-info:min
modify-tty-info:time
make-tty-info copy-tty-info
tty-info

116
scsh/scsh-package.scm
View File

@ -27,12 +27,16 @@
(define-structure error-package (export error warn)
(open signals))
(open signals)
(optimize auto-integrate)
)
(define-structure scsh-utilities scsh-utilities-interface
(open bitwise error-package let-opt scheme)
(files utilities))
(open bitwise error-package loopholes let-opt scheme)
(files utilities)
(optimize auto-integrate)
)
;;; This guy goes into the FOR-SYNTAX part of scsh's syntax exports.
@ -44,24 +48,36 @@
scsh-utilities ; check-arg
scheme
)
(files syntax-helpers))
(files syntax-helpers)
(optimize auto-integrate)
)
;;; The bufpol/{block, line, none} values
(define-structure buffered-io-flags buffered-io-flags-interface
(open defenum-package scheme)
(files (machine bufpol)))
(files (machine bufpol))
(optimize auto-integrate)
)
(define-structure char-set-package char-set-interface
(open error-package ascii scheme)
(files char-set))
(open error-package
ascii
define-record-types ; JAR's record macro.
scsh-utilities ; For DEPRECATED-PROC
scheme)
(files char-set)
(optimize auto-integrate)
)
(define-structures ((tty-flags tty-flags-interface)
(scsh-internal-tty-flags scsh-internal-tty-flags-interface))
(open scheme ascii bitwise)
(files (machine tty-consts)))
(files (machine tty-consts))
(optimize auto-integrate)
)
(define-structure scsh-version scsh-version-interface
@ -126,10 +142,10 @@
(scsh-level-0-internals (export set-command-line-args!
init-scsh-hindbrain
init-scsh-vars))
(scsh-regexp-package scsh-regexp-interface))
(open
;scheme define-foreign-syntax defrec-package receiving ascii
enumerated
; (scsh-regexp-package scsh-regexp-interface)
)
(for-syntax (open scsh-syntax-helpers scheme))
(open enumerated
external-calls ;JMG new FFI
structure-refs
cig-aux
@ -143,7 +159,7 @@
records
extended-ports
partial-s48-ports
ports
; ports
build
bigbit
bitwise
@ -162,13 +178,20 @@
scsh-internal-tty-flags ; Not exported
let-opt ; optional-arg parsing & defaulting
architecture
architecture ; Was this by JMG ??
interrupts ; signal handler code
re-level-0
rx-syntax
string-lib
loopholes ; For my bogus CALL-TERMINALLY implementation.
scheme
i/o
i/o ; all these seem to be for scsh-0.6 JMG
i/o-internal
channels channel-i/o
low-channels
@ -200,7 +223,7 @@
filesys
fileinfo
glob
filemtch
; filemtch
time ; New in release 0.2.
(machine time_dep)
network ; New in release 0.3.
@ -210,19 +233,25 @@
pty ; New in release 0.4.
sighandlers ; New in release 0.5.
scsh
; re
; rdelim
))
; re
; rdelim ;rdelim omitted for noew by JMG
)
; (optimize auto-integrate)
)
(define-structure defrec-package (export (define-record :syntax))
(open records scheme)
(for-syntax (open scheme error-package receiving))
(files defrec))
(files defrec)
(optimize auto-integrate)
)
(define-structure defenum-package (export (define-enum-constant :syntax)
(define-enum-constants :syntax))
(open scheme)
(files enumconst))
(files enumconst)
(optimize auto-integrate)
)
;;; This code opens so many modules of gruesome, low-level S48 internals
;;; that these two modules are segregated into separate packages, each
@ -278,10 +307,12 @@
(define-structure field-reader-package scsh-field-reader-interface
(open receiving ; receive
char-set-package
scsh-utilities
scsh-utilities ; nth
error-package ; error
scsh-level-0 ; delimited readers
scsh-regexp-package
; scsh-regexp-package
re-exports
string-lib ; join-strings
let-opt ; optional-arg parsing & defaulting
scheme
)
@ -289,46 +320,63 @@
(define-structures
((awk-expander-package (export expand-awk))
((awk-expander-package (export expand-awk expand-awk/obsolete))
(awk-support-package (export next-range next-:range
next-range: next-:range:)))
(open receiving ; receive
scsh-utilities
error-package ; error
scsh-regexp-package
; scsh-regexp-package
; re-exports
sre-syntax-tools
scheme
)
(files awk))
(define-structure awk-package awk-interface
(open awk-support-package scsh-regexp-package receiving scheme)
(open awk-support-package ; These packages provide all the stuff
re-exports ; that appears in the code produced by
receiving ; an awk expansion.
scheme)
(for-syntax (open awk-expander-package scheme))
(begin (define-syntax awk expand-awk)))
(begin (define-syntax awk expand-awk)
(define-syntax awk/posix-string expand-awk/obsolete)))
;;; Exports an AWK macro that is just AWK/POSIX-STRING.
(define-structure obsolete-awk-package (export (awk :syntax))
(open awk-package)
(begin (define-syntax awk
(syntax-rules () ((awk body ...) (awk/posix-string body ....))))))
(define-structure scsh
(compound-interface (interface-of scsh-level-0)
(interface-of scsh-startup-package)
;JMG scsh-regexp-interface
;JMG scsh-field-reader-interface ; new in 0.3
; scsh-regexp-interface
re-exports-interface
re-old-funs-interface
scsh-field-reader-interface ; new in 0.3
; scsh-dbm-interface
(export repl)
; JMG:awk-interface
awk-interface
)
(open structure-refs
scsh-level-0
scsh-level-0-internals
scsh-regexp-package
re-exports
re-old-funs
; scsh-regexp-package
scsh-startup-package
; dbm
; awk-package
; field-reader-package
awk-package
field-reader-package
scheme)
(access scsh-top-package)
(begin (define repl (structure-ref scsh-top-package repl))))
(begin (define repl (structure-ref scsh-top-package repl)))
(optimize auto-integrate)
)
(define-structure scsh-here-string-hax (export)
(open reading

21
scsh/time.scm
View File

@ -65,6 +65,18 @@
(define set-date:week-day set-%date:week-day)
(define set-date:year-day set-%date:year-day)
(define modify-date:seconds modify-%date:seconds)
(define modify-date:minute modify-%date:minute)
(define modify-date:hour modify-%date:hour)
(define modify-date:month-day modify-%date:month-day)
(define modify-date:month modify-%date:month)
(define modify-date:year modify-%date:year)
(define modify-date:tz-name modify-%date:tz-name)
(define modify-date:tz-secs modify-%date:tz-secs)
(define modify-date:summer? modify-%date:summer?)
(define modify-date:week-day modify-%date:week-day)
(define modify-date:year-day modify-%date:year-day)
(define (make-date s mi h md mo y . args)
(let-optionals args ((tzn #f) (tzs #f) (s? #f) (wd 0) (yd 0))
(make-%date s mi h md mo y tzn tzs s? wd yd)))
@ -295,14 +307,15 @@
(if (< offset 0)
(values #\+ (- offset)) ; Notice the flipped sign
(values #\- offset)) ; of SIGN.
(let* ((offset (modulo offset 86400))
(h (quotient offset 3600))
(let* ((offset (modulo offset 86400)) ; seconds/day
(h (quotient offset 3600)) ; seconds/hour
(m (quotient (modulo offset 3600) 60))
(s (modulo offset 60)))
(if (zero? s)
(if (zero? m)
(format #f "~a~a~d" name sign h) ; name+h
(format #f "~a~a~a:~a" ; name+hh:mm
sign (two-digits h) (two-digits m)))
name sign (two-digits h) (two-digits m)))
(format #f "~a~a~a:~a:~a" ; name+hh:mm:ss
sign (two-digits h) (two-digits m) (two-digits s)))))))
name sign
(two-digits h) (two-digits m) (two-digits s)))))))

52
scsh/tty.scm
View File

@ -70,6 +70,14 @@
(define set-tty-info:min set-%tty-info:min)
(define set-tty-info:time set-%tty-info:time)
(define modify-tty-info:control-chars modify-%tty-info:control-chars)
(define modify-tty-info:input-flags modify-%tty-info:input-flags)
(define modify-tty-info:output-flags modify-%tty-info:output-flags)
(define modify-tty-info:control-flags modify-%tty-info:control-flags)
(define modify-tty-info:local-flags modify-%tty-info:local-flags)
(define modify-tty-info:min modify-%tty-info:min)
(define modify-tty-info:time modify-%tty-info:time)
;;; Encode the speeds at assignment time.
(define (set-tty-info:input-speed info speed)
(set-%tty-info:input-speed-code info (encode-baud-rate speed))
@ -79,6 +87,11 @@
(set-%tty-info:output-speed-code info (encode-baud-rate speed))
(set-%tty-info:output-speed info speed))
(define (modify-tty-info:input-speed info proc)
(set-tty-info:input-speed info (proc (tty-info:input-speed info))))
(define (modify-tty-info:output-speed info proc)
(set-tty-info:output-speed info (proc (tty-info:output-speed info))))
(define (make-tty-info iflags oflags cflags lflags ispeed ospeed min time)
(make-%tty-info (make-string num-ttychars (ascii->char 0))
@ -101,9 +114,14 @@
(tty-info:time info)))
;;; (tty-info fd/port)
(define (sleazy-call/file tty opener proc)
(if (string? tty) (opener tty proc)
(sleazy-call/fdes tty proc)))
;;; (tty-info [fd/port/fname])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Retrieve tty-info bits from a tty.
;;; Retrieve tty-info bits from a tty. Arg defaults to current input port.
(define (tty-info fdport)
(let ((control-chars (make-string num-ttychars)))
@ -138,11 +156,33 @@
integer integer
integer integer)
(define-foreign %bogus-tty-info/errno
("scheme_tcgetattrB" (integer fdes)
(var-string control-chars)
(vector-desc ivec))
(to-scheme integer errno_or_false))
;;; (set-tty-info fdport option info) [Not exported]
;;; (set-tty-info/now fdport option info)
;;; (set-tty-info/drain fdport option info)
;;; (set-tty-info/flush fdport option info)
(define-errno-syscall (%bogus-tty-info fdes control-chars ivec)
%bogus-tty-info/errno)
(define (%%bogus-tty-info fd control-chars)
(let ((ivec (make-vector 10)))
(%bogus-tty-info fd control-chars ivec)
ivec))
;(define (%tty-info fdes cc)
; (let ((ivec (%%bogus-tty-info fdes cc)))
; (values (vector-ref ivec 0) (vector-ref ivec 1)
; (vector-ref ivec 2) (vector-ref ivec 3)
; (vector-ref ivec 4) (vector-ref ivec 5)
; (vector-ref ivec 6) (vector-ref ivec 7)
; (vector-ref ivec 8) (vector-ref ivec 9)
; cc)))
;;; (set-tty-info tty option info) [Not exported]
;;; (set-tty-info/now tty option info)
;;; (set-tty-info/drain tty option info)
;;; (set-tty-info/flush tty option info)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Assign tty-info bits to a tty.

44
scsh/utilities.scm
View File

@ -41,6 +41,19 @@
val))))
(lp zero l)))
(define (fold kons knil lis)
(let lp ((lis lis) (ans knil))
(if (pair? lis)
(lp (cdr lis) (kons (car lis) ans))
ans)))
(define (fold-right kons knil lis)
(let recur ((lis lis))
(if (pair? lis)
(let ((head (car lis))) ; Won't need LIS after RECUR call.
(kons head (recur (cdr lis))))
knil)))
(define (filter pred list)
(letrec ((filter (lambda (list)
(if (pair? list)
@ -115,6 +128,37 @@
((< i 0) v)
(vector-set! v i (init i)))))
(define (vector-append . vecs)
(let* ((vlen (fold (lambda (v len) (+ (vector-length v) len)) 0 vecs))
(ans (make-vector vlen)))
(let lp1 ((vecs vecs) (to 0))
(if (pair? vecs)
(let* ((vec (car vecs))
(len (vector-length vec)))
(let lp2 ((from 0) (to to))
(cond ((< from len)
(vector-set! ans to (vector-ref vec from))
(lp2 (+ from 1) (+ to 1)))
(else (lp1 (cdr vecs) to)))))))
ans))
(define (vfold kons knil v)
(let ((len (vector-length v)))
(do ((i 0 (+ i 1))
(ans knil (kons (vector-ref v i) ans)))
((>= i len) ans))))
(define (vfold-right kons knil v)
(do ((i (- (vector-length v) 1) (- i 1))
(ans knil (kons (vector-ref v i) ans)))
((< i 0) ans)))
;;; We loophole the call to ERROR -- the point is that perhaps the
;;; user will interact with a breakpoint, and proceed with a new
;;; value, which we will then pass to a new invocation of CHECK-ARG
;;; for approval.
(define (check-arg pred val caller)
(if (pred val) val
(check-arg pred (error "Bad argument" val pred caller) caller)))