[Forward Port to Guile: Remove `define-record' and some cruft clinton@unknownlamer.org**20100327183604 Ignore-this: 904250a281a5393468bddddb385cf293 * `define-record' uses replaced with SRFI-9 `define-record-type' * Remove obsolete (scsh defrec) * (scsh time) interface no longer exports `modify-date:*' functions * Remove (scsh rdelim) in favor of (ice-9 rdelim) * Remove (scsh let-opt) in favor of (ice-9 optargs) * Remove unused (scsh jar-defrecord) module * Remove `call/cc' alias from (scsh utilities) (Guile now provides `call/cc' in the default environment) * Still doesn't work (a few more broken `define-syntax' macros using the incompatible explicit-renaming based `define-syntax' from scsh itself need to be replaced) ] hunk ./Makefile.am 7 - defrec.scm ekko.scm errno.scm fdports.scm features.scm \ + ekko.scm errno.scm fdports.scm features.scm \ hunk ./Makefile.am 10 - init.scm jar-defrecord.scm let-opt.scm \ + init.scm \ hunk ./Makefile.am 14 - rdelim.scm reading.scm rw.scm \ + reading.scm rw.scm \ hunk ./awk.scm 7 - :use-module (scsh rdelim) + :use-module (ice-9 rdelim) hunk ./defrec.scm 1 -;;; Copyright (c) 1993 by Olin Shivers. See file COPYING. - -;;; Syntax for defining record types. -;;; This implementation works with the Scheme48 system -- -;;; or any Scheme that uses Clinger's "explicit renaming" -;;; macro system. -;;; -;;; (define-record name . field&method-specs) -;;; -;;; A field-spec is one of the following: -;;; field ; Initialised field -;;; (field [default]) ; Defaulted field. -;;; An initialised field has its initial value passed as an argument to -;;; the the record maker procedure. A defaulted field takes its value from -;;; the the DEFAULT expression. If a DEFAULT expression is not given, then -;;; the defaulted field's initial value is undefined. -;;; -;;; Example: -;;; (define-record employee -;;; name -;;; id -;;; (salary 10000) -;;; (department) ; Initial value undefined. -;;; sex -;;; married?) -;;; -;;; Defines the following: -;;; - A maker procedure: -;;; (make-employee "John Smith" 742931 'male #f) -;;; MAKE-EMPLOYEE takes one argument for each initialised field. -;;; -;;; - Accessor procedures: -;;; (employee:name emp) -;;; (employee:id emp) -;;; (employee:salary emp) -;;; (employee:department emp) -;;; (employee:sex emp) -;;; (employee:married? emp) -;;; -;;; - Field-setting procedures: -;;; (set-employee:name emp "Janet Q. Random") -;;; (set-employee:id emp 8271) -;;; (set-employee:salary emp 20000) -;;; (set-employee:department emp "Vaporware") -;;; (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) -;;; -;;; - The record type descriptor: -;;; type/employee - -;;; Method specs are of the form -;;; ((method self var ...) body ...) -;;; The only supported method is DISCLOSE, which is used by the S48 -;;; structure printer. E.g., -;;; (define-record ship -;;; x -;;; y -;;; name -;;; ((disclose self) (list "ship" (ship:name self)))) -;;; 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-module (scsh defrec) - :use-module (ice-9 receive) - :use-module (srfi srfi-1) -) -(export-syntax define-record-discloser define-record) - -;;; added for guile. perhaps use a separate module for rts/record.scm? -(defmacro define-record-discloser args #f) - -;;; BROKEN -(define-syntax define-record - (lambda (form rename compare) - (receive (field-specs method-specs) - ;; Partition the field and method specs by form. - (let lp ((specs (reverse (cddr form))) - (fspecs '()) - (mspecs '())) - (if (pair? specs) - (let ((spec (car specs)) - (specs (cdr specs))) - (if (and (pair? spec) (pair? (car spec))) - ;; We only support the DISCLOSE method in S48. - (if (eq? (caar spec) 'disclose) - (lp specs fspecs (cons spec mspecs)) - (error "Unsupported method in define-record." spec)) - (lp specs (cons spec fspecs) mspecs))) - (values fspecs mspecs))) - - (let* ((name (cadr form)) - (s->s symbol->string) - (s-conc (lambda args (string->symbol (apply string-append args)))) - (spec-name (lambda (s) (if (pair? s) (car s) s))) - (filter (lambda (pred lst) - (let f ((lst lst)) - (if (pair? lst) - (let ((tail (f (cdr lst)))) - (if (pred (car lst)) (cons (car lst) tail) tail)) - '())))) - (gensym (let ((j 0)) - (lambda (s) (set! j (+ j 1)) - (s-conc s (number->string j))))) - - (field-name (lambda (field-name) - (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))) - - (fields (map spec-name field-specs)) - (param-fields (filter symbol? field-specs)) ; Args to maker proc. - (default-field-specs (filter (lambda (fs) (and (pair? fs) - (pair? (cdr fs)))) - field-specs)) - (default-exps (map cadr default-field-specs)) - (param-vars (map (lambda (fs) (rename (gensym "field"))) - param-fields)) - - (maker (rename 'maker)) - (%make-record-type (rename 'make-record-type)) - (%record-constructor (rename 'record-constructor)) - (%record-predicate (rename 'record-predicate)) - (%record-accessor (rename 'record-accessor)) - (%record-modifier (rename 'record-modifier)) - (%def-rec-discloser (rename 'define-record-discloser)) - (%unspecified (rename 'unspecified)) - (%define (rename 'define)) - (%let (rename 'let)) - (%lambda (rename 'lambda)) - (%begin (rename 'begin))) - - `(,%begin - (,%define ,type-name - (,%make-record-type ,(s->s name) ',fields)) - - ;; Maker proc (MAKE-EMPLOYEE name id-number sex married?) - (,%define ,maker-name - ,(if (null? default-field-specs) - ;; Gratuitous optimisation: - `(,%record-constructor ,type-name ',param-fields) - - ;; Full-blown form. - `(,%let ((,maker (,%record-constructor - ,type-name - ',(append param-fields - (map spec-name - default-field-specs))))) - (,%lambda ,param-vars - (,maker ,@param-vars ,@default-exps))))) - - ;; Type predicate (EMPLOYEE? x) - (,%define ,pred-name (,%record-predicate ,type-name)) - - ;; Accessors (EMPLOYEE:NAME emp), ... - ,@(map (lambda (field) - `(,%define ,(field-name field) - (,%record-accessor ,type-name ',field))) - fields) - - ;; 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) - `(,%def-rec-discloser ,type-name - (,%lambda ,(cdar m) . ,(cdr m)))) - method-specs) - ))))) rmfile ./defrec.scm hunk ./fdports.scm 6 - :use-module (scsh scsh) -) + :use-module (scsh scsh)) + hunk ./fileinfo.scm 12 - :use-module (scsh let-opt) hunk ./fileinfo.scm 14 - :use-module (scsh errno) -) + :use-module (scsh errno)) hunk ./fname.scm 17 - :use-module (scsh let-opt) hunk ./fr.scm 12 - :use-module (scsh let-opt) + :use-module (ice-9 optargs) hunk ./fr.scm 14 - :use-module (scsh rdelim) + :use-module (ice-9 rdelim) hunk ./fr.scm 105 - (let-optionals args ((delim-spec default-delim-matcher) + (let-optional args ((delim-spec default-delim-matcher) hunk ./fr.scm 145 - (let-optionals args ((field-spec default-field-matcher) + (let-optional args ((field-spec default-field-matcher) hunk ./fr.scm 320 - (let-optionals args ((delims default-record-delims) + (let-optional args ((delims default-record-delims) hunk ./fr.scm 374 - (let-optionals args ((parser default-field-parser) + (let-optional args ((parser default-field-parser) hunk ./here.scm 79 - :use-module (scsh rdelim)) + :use-module (ice-9 rdelim)) hunk ./init.scm 9 - (scsh let-opt) hunk ./init.scm 20 - (scsh jar-defrecord) hunk ./init.scm 22 - (scsh defrec) hunk ./init.scm 44 - (scsh rdelim) + (ice-9 rdelim) hunk ./init.scm 87 - (scsh scsh) -) + (scsh scsh)) hunk ./jar-defrecord.scm 1 -; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees. See file COPYING. - - -; This is JAR's define-record-type, which doesn't resemble Richard's. - -; There's no implicit name concatenation, so it can be defined -; entirely using syntax-rules. Example: -; (define-record-type foo :foo -; (make-foo x y) -; foo? - predicate name is optional -; (x foo-x) -; (y foo-y) -; (z foo-z set-foo-z!)) - -;; original file: rts/jar-defrecord.scm. -;; this should export -(define-module (scsh jar-defrecord)) -;; define-accessor[s] -(export-syntax define-record-type define-accessor define-accessors) - -(define-syntax define-record-type - (syntax-rules () - ((define-record-type ?id ?type - (?constructor ?arg ...) - (?field . ?field-stuff) - ...) - (begin (define ?type (make-record-type '?id '(?field ...))) - (define ?constructor (record-constructor ?type '(?arg ...))) - (define-accessors ?type (?field . ?field-stuff) ...))) - ((define-record-type ?id ?type - (?constructor ?arg ...) - ?pred - ?more ...) - (begin (define-record-type ?id ?type - (?constructor ?arg ...) - ?more ...) - (define ?pred (record-predicate ?type)))))) - -; Straightforward version -(define-syntax define-accessors - (syntax-rules () - ((define-accessors ?type ?field-spec ...) - (begin (define-accessor ?type . ?field-spec) ...)))) - -(define-syntax define-accessor - (syntax-rules () - ((define-accessor ?type ?field ?accessor) - (define ?accessor (record-accessor ?type '?field))) - ((define-accessor ?type ?field ?accessor ?modifier) - (begin (define ?accessor (record-accessor ?type '?field)) - (define ?modifier (record-modifier ?type '?field)))) - ((define-accessor ?type ?field) - (begin)))) rmfile ./jar-defrecord.scm hunk ./let-opt.scm 1 -;;; LET-OPTIONALS macros -;;; Copyright (c) 2001 by Olin Shivers. -;;; See file COPYING. - -;;; This file defines three macros for parsing optional arguments to procs: -;;; (LET-OPTIONALS arg-list (opt-clause1 ... opt-clauseN [rest]) -;;; body ...) -;;; (LET-OPTIONALS* arg-list (opt-clause1 ... opt-clauseN [rest]) -;;; body ...) -;;; (:OPTIONAL rest-arg default-exp [arg-check]) -;;; where -;;; ::= (var default [arg-check supplied?]) -;;; | ((var1 ... varN) external-arg-parser) -;;; -;;; LET-OPTIONALS* has LET* scope -- each arg clause sees the bindings of -;;; the previous clauses. LET-OPTIONALS has LET scope -- each arg clause -;;; sees the outer scope (an ARG-CHECK expression sees the outer scope -;;; *plus* the variable being bound by that clause, by necessity). -;;; -;;; In practice, LET-OPTIONALS* is the one you want. -;;; -;;; The only interesting module that is exported by this file is -;;; LET-OPT -;;; which obeys the following interface: -;;; (exports (let-optionals :syntax) -;;; (let-optionals* :syntax) -;;; (:optional :syntax)) -;;; -;;; The LET-OPTIONALS macro is defined using the Clinger/Rees -;;; explicit-renaming low-level macro system. You'll have to do some work to -;;; port it to another macro system. -;;; -;;; The :OPTIONAL macro is defined with simple high-level macros, -;;; and should be portable to any R4RS system. -;;; -;;; These macros are all careful to evaluate their default forms *only* if -;;; their values are needed. -;;; -;;; The LET-OPTIONALS expander is pretty hairy. Sorry. It does produce -;;; very good code. -;;; -;;; The top-level forms in this file are Scheme 48 module expressions. -;;; I use the module system to help me break up the expander code for -;;; LET-OPTIONALS into three procedures, which makes it easier to understand -;;; and test. But if you wanted to port this code to a module-less Scheme -;;; system, you'd probably have to inline the auxiliary procs into the actual -;;; macro definition. -;;; -;;; To repeat: This code is not simple Scheme code; it is module code. -;;; It must be loaded into the Scheme 48 ,config package, not the ,user -;;; package. -;;; -;;; The only non-R4RS dependencies in the macros are ERROR, RECEIVE, -;;; and CALL-WITH-VALUES. -;;; -;;; See below for details on each macro. -;;; -Olin - -;;; (LET-OPTIONALS* arg-list (clause ... [rest]) body ...) -;;; (LET-OPTIONALS arg-list (clause ... [rest]) body ...) -;;; -;;; clause ::= (var default [arg-test supplied?]) ; The simple case -;;; | ((var1 ...) external-arg-parser) ; external hook -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This form is for binding a procedure's optional arguments to either -;;; the passed-in values or a default. -;;; -;;; The expression takes a rest list ARG-LIST and binds the VARi to -;;; the elements of the rest list. When there are no more elements, then -;;; the remaining VARi are bound to their corresponding DEFAULTi values. -;;; It is an error if there are more args than variables. -;;; -;;; Simple example: -;;; (let-optionals* args ((in (current-input-port)) -;;; (out (current-output-port)) -;;; (nbytes (string-length s))) -;;; ...) -;;; -;;; - The default expressions are *not* evaluated unless needed. -;;; -;;; - When a LET-OPTIONALS* form is evaluated, the default expressions are -;;; carried out in a "sequential" LET*-style scope -- each clause is -;;; evaluated in a scope that sees the bindings introduced by the previous -;;; clauses. -;;; -;;; - LET-OPTIONALS, in contrast, evaluates all clauses in the *outer* -;;; environment. Each ARG-TEST form, however, does see the variable -;;; bound by that clause (see below). -;;; -;;; - If there's an ARG-TEST form, it is evaluated when an argument is -;;; passed in; it is not evaluated when the argument is defaulted. -;;; If it produces false, an error is raised. You can stick an arg-checking -;;; expression here. Here's the above example with full arg-checking: -;;; (let ((strlen (string-length s))) -;;; (let-optionals args ((in (current-input-port) (input-port? in)) -;;; (out (current-output-port) (output-port? out)) -;;; (nbytes strlen (and (integer? nbytes) -;;; (< -1 nbytes strlen)))) -;;; ...)) -;;; -;;; The ARG-TEST expression is evaluated in the outer scope of the LET, -;;; plus a binding for the parameter being checked. -;;; -;;; - A SUPPLIED? variable is bound to true/false depending on whether or -;;; not a value was passed in by the caller for this parameter. -;;; -;;; - If there's a final REST variable in the binding list, it is bound -;;; to any leftover unparsed values from ARG-LIST. If there isn't a final -;;; REST var, it is an error to have extra values left. You can use this -;;; feature to parse a couple of arguments with LET-OPTIONALS, and handle -;;; following args with some other mechanism. It is also useful for -;;; procedures whose final arguments are homogeneous. -;;; -;;; - A clause of the form ((var1 ... varn) external-arg-parser) allows you -;;; to parse & arg-check a group of arguments together. EXTERNAL-ARG-PARSER -;;; is applied to the argument list. It returns n+1 values: one -;;; for the leftover argument list, and one for each VARi. -;;; -;;; This facility is intended for things like substring start/end index -;;; pairs. You can abstract out the code for parsing the pair of arguments -;;; in a separate procedure (parse-substring-index-args args string proc) -;;; and then a function such as READ-STRING! can simply invoke the procedure -;;; with a -;;; ((start end) (lambda (args) (parse-substring-index-args args s read-string!))) -;;; clause. That is, the external-arg parser facility is a hook -;;; that lets you interface other arg parsers into LET-OPTIONALS. - -;;; Expanding the form -;;;;;;;;;;;;;;;;;;;;;; -;;; We expand the form into a code DAG that avoids repeatedly testing the -;;; arg list once it runs out, but still shares code. For example, -;;; -;;; (define (read-string! str . maybe-args) -;;; (let-optionals* maybe-args ((port (current-input-port)) -;;; (start 0) -;;; (end (string-length str))) -;;; ...)) -;;; -;;; expands to: -;;; -;;; (let* ((body (lambda (port start end) ...)) -;;; (end-def (lambda (port start) (body port start ))) -;;; (start-def (lambda (port) (end-def port ))) -;;; (port-def (lambda () (start-def )))) -;;; (if (pair? tail) -;;; (let ((port (car tail)) -;;; (tail (cdr tail))) -;;; (if (pair? tail) -;;; (let ((start (car tail)) -;;; (tail (cdr tail))) -;;; (if (pair? tail) -;;; (let ((end (car tail)) -;;; (tail (cdr tail))) -;;; (if (pair? tail) -;;; (error ...) -;;; (body port start end))) -;;; (end-def port start))) -;;; (start-def port))) -;;; (port-def))) -;;; -;;; Note that the defaulter code (the chain of ...-DEF procs) is just a -;;; linear sequence of machine code into which the IF-tree branches. Once -;;; we jump into the defaulter chain, we never test the arg list again. -;;; A reasonable compiler can turn this into optimal parameter-parsing code. - -(define-module (scsh let-opt) - :use-module (ice-9 receive) - :use-module (scsh module-system)) - -(export-syntax let-optionals let-optionals* :optional) - -(define-structure let-opt-expanders (export expand-let-optionals - expand-let-optionals*) - (open scheme - error-package - receiving) - (begin - -(define (make-gensym prefix) - (let ((counter 0)) - (lambda () - (set! counter (+ counter 1)) - (string->symbol (string-append prefix (number->string counter)))))) - -;;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above. -;;; If an elt of VARS is a list, we are dealing with a group-parser clause. -;;; In this case, the corresponding element of DEFS is the name of -;;; the parser. -;;; I wish I had a reasonable loop macro. -;;; -;;; DEFAULTER-NAMES also holds the xparser expressions -;;; - STAR? true -;;; LET* scope semantics -- default I & xparser I are evaluated in -;;; a scope that sees vars 1 ... I-1. -;;; - STAR? false -;;; LET scope semantics -- default and xparser forms don't see any of the -;;; vars. -;;; -;;; I considered documenting this procedure better, but finally decided -;;; that if it was this hard for me to write, it should be hard for you -;;; to read. -Olin - -(define (make-default-procs vars body-proc defaulter-names defs - sup-vars rest-var star? rename) - (receive (defaulters ignore-me and-me-too) - (really-make-default-procs vars body-proc defaulter-names defs - sup-vars rest-var star? rename) - (reverse defaulters))) - -(define (really-make-default-procs vars body-proc defaulter-names defs - sup-vars rest-var star? rename) - (let ((%lambda (rename 'lambda)) - (%let (rename 'let)) - (%ignore (rename '_)) - (%call/values (rename 'call-with-values)) - (tail (rename 'tail)) - (make-rv (let ((g (make-gensym "%ov."))) - (lambda x (rename (g))))) - (make-sv (let ((g (make-gensym "%sv."))) - (lambda () (rename (g)))))) - - ;; RECUR returns 2 values: a LET*-binding list of defaulter proc - ;; bindings, and an expression to evaluate in their scope. - (let recur ((vars vars) - (rev-params '()) ; These guys - (rev-vals '()) ; have these values. - (sup-vars sup-vars) - (rev-sup-params '()) ; These guys - (rev-sup-vals '()) ; have these values. - (defaulter-names defaulter-names) - (defs defs)) - ;; Note that the #F's bound to the SUPPLIED? parameters have no - ;; effects, and so commute with the evaluation of the defaults. - ;; Hence we don't need the VALS-EVALED? trick for them, just for the - ;; default forms & their parameters. - (if (pair? vars) - (let* ((var (car vars)) (vars (cdr vars)) ; "VAR" is really a list - (def (car defs)) (defs (cdr defs)) ; in xparser case... - (rvar (if star? var ; scope control - (if (pair? var) (map make-rv var) (make-rv)))) - (rev-params1 (if (pair? rvar) - (append (reverse rvar) rev-params) - (cons rvar rev-params))) - (rev-vals1 (if (pair? rvar) rev-params1 - (cons def rev-params))) - (sv (car sup-vars)) - (sv (if (or star? (not sv)) sv (make-sv))) - (rev-sup-params1 (if sv (cons sv rev-sup-params) - rev-sup-params)) - (rev-sup-vals1 (cond (sv (cons #f rev-sup-params)) - ((pair? var) rev-sup-vals) - (else rev-sup-params))) - (defaulter (car defaulter-names)) - (defaulter-names (cdr defaulter-names))) - (receive (procs exp vals-evaled?) - (recur vars rev-params1 rev-vals1 (cdr sup-vars) - rev-sup-params1 rev-sup-vals1 - defaulter-names defs) - (if (pair? var) - ;; Return #f for VALS-EVALED? so we'll force any prior - ;; default to be eval'd & not pushed below this default eval. - (values procs - `(,%call/values (,%lambda () (,defaulter '())) - (,%lambda ,(cons %ignore rvar) ,exp)) - #f) - - (let ((params (reverse (append rev-sup-params rev-params))) - (exp (if vals-evaled? exp - `(,%let ((,rvar ,def)) ,exp)))) - (values `((,defaulter (,%lambda ,params ,exp)) - . ,procs) - `(,defaulter ,@(reverse rev-vals) - ,@(reverse rev-sup-vals)) - #t))))) - - (values '() `(,body-proc ,@(if rest-var '('()) '()) - ,@(reverse rev-vals) - . ,(reverse rev-sup-vals)) - #t))))) - - -;;; This guy makes the (IF (PAIR? TAIL) ... (PORT-DEF)) tree above. -;;; DEFAULTERS is a list of the names of the defaulter procs & the xparser -;;; forms. - -(define (make-if-tree vars defaulters arg-tests body-proc - tail supvars rest-var star? rename) - (let ((%if (rename 'if)) - (%pair? (rename 'pair?)) - (%not (rename 'not)) - (%error (rename 'error)) - (%let (rename 'let)) - (%lambda (rename 'lambda)) - (%call/values (rename 'call-with-values)) - (%car (rename 'car)) - (%cdr (rename 'cdr)) - (make-rv (let ((g (make-gensym "%ov."))) - (lambda x (rename (g)))))) - - (let recur ((vars vars) (defaulters defaulters) - (ats arg-tests) (non-defaults '()) - (supvars supvars) (sup-trues '())) - (if (null? vars) - (if rest-var - `(,body-proc ,tail ,@(reverse non-defaults) . ,sup-trues) - `(,%if (,%pair? ,tail) - (,%error "Too many optional arguments." ,tail) - (,body-proc ,@(reverse non-defaults) . ,sup-trues))) - - (let* ((v (car vars)) - (rv (if star? v ; Scope control - (if (pair? v) (map make-rv v) (make-rv)))) - (at (car ats)) - (sup-trues1 (if (car supvars) (cons #t sup-trues) sup-trues)) - - (body `(,@(if (not (eq? at #t)) - (let ((test (if star? at - `(,%let ((,v ,rv)) ,at)))) - `((,%if (,%not ,test) - (,%error "Optional argument failed test" - ',at ',v ,rv)))) - '()) ; No arg test - ,(recur (cdr vars) - (cdr defaulters) - (cdr ats) - (if (pair? rv) - (append (reverse rv) non-defaults) - (cons rv non-defaults)) - (cdr supvars) sup-trues1)))) - (if (pair? rv) - `(,%call/values (,%lambda () - (,(car defaulters) ,tail)) - (,%lambda (,tail . ,rv) . ,body)) - - `(,%if (,%pair? ,tail) - (,%let ((,rv (,%car ,tail)) - (,tail (,%cdr ,tail))) - . ,body) - (,(car defaulters) ,@(reverse non-defaults) . ,sup-trues)))))))) - - -;;; Parse the clauses into -;;; - a list of vars, -;;; - a list of defaults, -;;; - a list of possible arg-tests. No arg-test is represented as #T. -;;; - a list of possible SUPPLIED? vars. An elt is either (var) or #f. -;;; - either the rest var or #f -;;; -;;; This is written out in painful detail so that we can do a lot of -;;; syntax checking. - -(define (parse-clauses bindings) - ;; LIST-LIB defines EVERY... but uses LET-OPTIONALS. - ;; Define here to break the dependency loop: - (define (every pred lis) - (or (not (pair? lis)) (and (pred (car lis)) (every pred (car lis))))) - - (cond ((pair? bindings) - (let ((rev (reverse bindings))) - (receive (rest-var rev) (if (symbol? (car rev)) - (values (car rev) (cdr rev)) - (values #f rev)) - (receive (vars defs ats supvars) - (let recur ((bindings (reverse rev))) - (if (not (pair? bindings)) - (values '() '() '() '()) - (receive (vars defs ats supvars) (recur (cdr bindings)) - (let ((binding (car bindings))) - (if (not (and (list? binding) (<= 2 (length binding) 4))) - (error "Illegal binding form in LET-OPTIONAL or LET-OPTIONAL*" - binding)) - - (let* ((var (car binding)) - (vars (cons var vars)) - (defs (cons (cadr binding) defs)) - (stuff (cddr binding))) - (if (not (or (symbol? var) - (and (list? var) - (= 2 (length binding)) - (every symbol? var)))) - (error "Illegal parameter in LET-OPTIONAL or LET-OPTIONAL* binding" - binding)) - (receive (at sup-var) - (if (not (pair? stuff)) (values #t #f) - (let ((at (car stuff)) - (stuff (cdr stuff))) - (if (not (pair? stuff)) - (values at #f) - (let ((sv (car stuff))) - (if (not (symbol? sv)) - (error "Illegal SUPPLIED? parameter in LET-OPTIONAL or LET-OPTIONAL*" - binding sv)) - (values at sv))))) - (values vars defs (cons at ats) (cons sup-var supvars)))))))) - (values vars defs ats supvars rest-var))))) - - ((null? bindings) (values '() '() '() '() #f)) - (else (error "Illegal bindings to LET-OPTIONAL or LET-OPTIONAL* form" - bindings)))) - -(define (really-expand-let-optionals exp star? rename compare?) - (let* ((arg-list (cadr exp)) - (var/defs (caddr exp)) - (body (cdddr exp)) - - (body-proc (rename 'body)) - (tail-var (rename '%tail)) ; Bound to remaining args to be parsed. - - (%let* (rename 'let*)) - (%lambda (rename 'lambda)) - - (prefix-sym (lambda (prefix sym) - (string->symbol (string-append prefix (symbol->string sym)))))) - - (receive (vars defs arg-tests maybe-supvars maybe-rest) - (parse-clauses var/defs) - (let* ((defaulter-names (map (lambda (var def) - (if (pair? var) - def ; xparser - (rename (prefix-sym "def-" var)))) - vars defs)) - (rsupvars (if star? maybe-supvars - (let ((g (make-gensym "%sv."))) - (map (lambda (x) (and x (rename (g)))) - maybe-supvars)))) - (just-supvars (let recur ((svs maybe-supvars)) ; filter - (if (not (pair? svs)) '() - (let ((sv (car svs)) - (tail (recur (cdr svs)))) - (if sv (cons sv tail) tail))))) - - (defaulters (make-default-procs vars body-proc defaulter-names - defs rsupvars maybe-rest - star? rename)) - - (if-tree (make-if-tree vars defaulter-names arg-tests body-proc - tail-var rsupvars maybe-rest star? rename)) - - ;; Flatten out the multi-arg items. - (allvars (apply append (map (lambda (v) (if (pair? v) v - (list v))) - vars)))) - - `(,%let* ((,tail-var ,arg-list) - (,body-proc (,%lambda ,(append (if maybe-rest - (cons maybe-rest allvars) - allvars) - just-supvars) - . ,body)) - . ,defaulters) - ,if-tree))))) - -(define (expand-let-optionals exp rename compare?) - (really-expand-let-optionals exp #f rename compare?)) -(define (expand-let-optionals* exp rename compare?) - (really-expand-let-optionals exp #t rename compare?)) - - -)) ; erutcurts-enifed -;;; nilO- .noitnevnoc gnitekcarb sugob a ni deppart m'I !pleh !pleh - -;;; Here is where we define the macros, using the expanders from the above -;;; package. - -(define-structure let-opt (export (let-optionals :syntax) - (let-optionals* :syntax) - (:optional :syntax)) - (open scheme error-package) - (for-syntax (open let-opt-expanders scheme)) - (begin - - -;;; (LET-OPTIONALS args ((var1 default1 [arg-test supplied?]) ...) body1 ...) -;;; (LET-OPTIONALS* args ((var1 default1 [arg-test supplied?]) ...) body1 ...) - -;;; BROKEN -(define-syntax let-optionals expand-let-optionals) -(define-syntax let-optionals* expand-let-optionals*) - -;;; (:optional rest-arg default-exp [test-pred]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This form is for evaluating optional arguments and their defaults -;;; in simple procedures that take a *single* optional argument. It is -;;; a macro so that the default will not be computed unless it is needed. -;;; -;;; REST-ARG is a rest list from a lambda -- e.g., R in -;;; (lambda (a b . r) ...) -;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that. -;;; - If REST-ARG has 1 element, return that element. -;;; - If REST-ARG has >1 element, error. -;;; -;;; If there is an TEST-PRED form, it is a predicate that is used to test -;;; a non-default value. If the predicate returns false, an error is raised. - -(define-syntax :optional - (syntax-rules () - ((:optional rest default-exp) - (let ((maybe-arg rest)) - (if (pair? maybe-arg) - (if (null? (cdr maybe-arg)) (car maybe-arg) - (error "too many optional arguments" maybe-arg)) - default-exp))) - - ((:optional rest default-exp arg-test) - (let ((maybe-arg rest)) - (if (pair? maybe-arg) - (if (null? (cdr maybe-arg)) - (let ((val (car maybe-arg))) - (if (arg-test val) val - (error "Optional argument failed test" - 'arg-test val))) - (error "too many optional arguments" maybe-arg)) - default-exp))))) - -)) ; erutcurts-enifed - - -;;; Here is a simpler but less-efficient version of LET-OPTIONALS*. -;;; It redundantly performs end-of-list checks for every optional var, -;;; even after the list runs out. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; (define-structure slow-simple-let-opt (export (let-optionals* :syntax)) -; (open scheme) -; (begin - -; (define-syntax let-optionals* -; (syntax-rules () -; ((let-optionals* arg (opt-clause ...) body ...) -; (let ((rest arg)) -; (let-optionals* rest (opt-clause ...) body ...))))) - -; ;;; The arg-list expression *must* be a variable. -; ;;; (Or must be side-effect-free, in any event.) - -; (define-syntax %let-optionals* -; (syntax-rules () -; ((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...) -; (call-with-values (lambda () (xparser arg)) -; (lambda (rest var ...) -; (%let-optionals* rest (opt-clause ...) body ...)))) - -; ((%let-optionals* arg ((var default) opt-clause ...) body ...) -; (call-with-values (lambda () (if (null? arg) (values default '()) -; (values (car arg) (cdr arg)))) -; (lambda (var rest) -; (%let-optionals* rest (opt-clause ...) body ...)))) - -; ((%let-optionals* arg ((var default test) opt-clause ...) body ...) -; (call-with-values (lambda () -; (if (null? arg) (values default '()) -; (let ((var (car arg))) -; (if test (values var (cdr arg)) -; (error "arg failed LET-OPT test" var))))) -; (lambda (var rest) -; (%let-optionals* rest (opt-clause ...) body ...)))) - -; ((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...) -; (call-with-values (lambda () -; (if (null? arg) (values default #f '()) -; (let ((var (car arg))) -; (if test (values var #t (cdr arg)) -; (error "arg failed LET-OPT test" var))))) -; (lambda (var supplied? rest) -; (%let-optionals* rest (opt-clause ...) body ...)))) - -; ((%let-optionals* arg (rest) body ...) -; (let ((rest arg)) body ...)) - -; ((%let-optionals* arg () body ...) -; (if (null? arg) (begin body ...) -; (error "Too many arguments in let-opt" arg))))) -; )) ; erutcurts-enifed - - -; ;;; Example derived syntax: -; ;;; - (fn (var ...) (opt-clause ...) body ...) -; ;;; - (defn (name var ...) (opt-clause ...) body ...) -; ;;; - (defn name exp) -; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -; (define-structure defn-package (export (fn :syntax) -; (defn :syntax)) -; (open let-opt scheme) -; (begin - -; (define-syntax fn -; (syntax-rules () -; ((fn vars () body ...) (lambda vars body ...)) -; ((fn (var ...) opts body ...) -; (lambda (var ... . rest) -; (let-optionals rest opts body ...))))) - -; (define-syntax defn -; (syntax-rules () -; ((defn (name . params) opts body ...) -; (define name (fn params opts body ...))) -; ((defn name val) (define name val)))) -; )) ; erutcurts-enifed - - -; ;;; Another example derived syntax -- Common-Lisp style fun: -; ;;; (FUN (var ... &OPTIONAL opt-clause ... &REST rest-var) body ...) -; ;;; (DEFUN (name var ... &OPTIONAL opt-clause ... &REST rest-var) -; ;;; body ...) -; ;;; (DEFUN name exp) -; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -; (define-structure defun-package (export (fun :syntax) -; (defun :syntax)) -; (open let-opt scheme) -; (begin - -; (define-syntax fun -; (syntax-rules () -; ((fun args body ...) (%fun1 () () () args body ...)))) - -; ;;; This guy basically parses the pieces of the parameter list. -; (define-syntax %fun1 -; (syntax-rules (&optional &rest) - -; ((%fun1 reg opt () (&optional &rest var) body ...) -; (%fun2 reg opt var body ...)) - -; ((%fun1 reg opt () (&rest var) body ...) -; (%fun2 reg opt var body ...)) - -; ((%fun1 reg opt () (&optional) body ...) -; (%fun2 reg opt () body ...)) - -; ((%fun1 reg opt () () body ...) -; (%fun2 reg opt () body ...)) - -; ((%fun1 reg (opt ...) () (&optional opt1 opt2 ...) body ...) -; (%fun1 reg (opt ... opt1) () (&optional opt2 ...) body ...)) - -; ((%fun1 (var1 ...) opt () (varn varn+1 ...) body ...) -; (%fun1 (var1 ... varn) opt () (varn+1 ...) body ...)))) - -; ;;; This guy does the expansion into a LET-OPTIONALS*. -; (define-syntax %fun2 -; (syntax-rules () -; ((%fun2 (var ...) () rest body ...) -; (lambda (var ... . rest) body ...)) -; ((%fun2 (v1 ...) opts () body ...) -; (lambda (v1 ... . rest) (let-opt rest opts body ...))) -; ((%fun2 (v1 ...) (opt1 ...) rest body ...) -; (lambda (v1 ... . %rest) (let-opt %rest (opt1 ... rest) body ...))))) - -; (define-syntax defun -; (syntax-rules () -; ((defun (name arg ...) body ...) -; (define name (fun (arg ...) body ...))) - -; ((defun name exp) (define name exp)))) -; )) ; erutcurts-enifed rmfile ./let-opt.scm hunk ./network.scm 10 - :use-module (scsh let-opt) + :use-module (ice-9 optargs) hunk ./network.scm 13 - :use-module (scsh defrec) -) + :use-module (srfi srfi-9)) + hunk ./network.scm 125 -(define-record socket - family ; protocol family - inport ; input port - outport) ; output port +(define-record-type type/socket + (make-socket family inport outport) + socket? + (family socket:family set-socket:family) ; protcol family + (inport socket:inport set-socket:inport) ; input port + (outport socket:outport set-socket:outport)) ; output port + +(define-record-type type/socket-address + (make-socket-address family address) + socket-address? + (family socket-address:family set-socket-address:family) ; protcol family + (address socket-address:address set-socket-address:address)) ; address hunk ./network.scm 138 -(define-record socket-address - family ; address family - address) ; address hunk ./network.scm 446 - (let-optionals args ((start 0) (end (string-length s)) (flags 0)) + (let-optional args ((start 0) (end (string-length s)) (flags 0)) hunk ./network.scm 498 - (let-optionals args ((start 0) (end (string-length s)) (flags 0)) + (let-optional args ((start 0) (end (string-length s)) (flags 0)) hunk ./network.scm 548 - (let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f)) + (let-optional args ((start 0) (end (string-length s)) (flags 0) (addr #f)) hunk ./network.scm 579 - (let-optionals args ((start 0) (end (string-length s)) (flags 0) (addr #f)) + (let-optional args ((start 0) (end (string-length s)) (flags 0) (addr #f)) hunk ./network.scm 756 -(define-record host-info - name ; Host name - aliases ; Alternative names - addresses ; Host addresses - - ((disclose hi) ; Make host-info records print like - (list "host" (host-info:name hi)))) ; #{host clark.lcs.mit.edu}. +(define-record-type type/host-info + (make-host-info name aliases addresses) + host-info? + (name host-info:name set-host-info:name) + (aliases host-info:aliases set-host-info:aliases) + (addresses host-info:addresses set-host-info:addresses)) hunk ./network.scm 805 -(define-record network-info - name ; Network name - aliases ; Alternative names - net) ; Network number +(define-record-type type/network-info + (make-network-info name aliases net) + network-info? + (name network-info:name set-network-info:name) + (aliases network-info:aliases set-network-info:aliases) + (net network-info:net set-network-info:net)) hunk ./network.scm 852 -(define-record service-info - name ; Service name - aliases ; Alternative names - port ; Port number - protocol) ; Protocol name +(define-record-type type/service-info + (make-service-info name aliases port protocol) + service-info? + (name service-info:name set-service-info:name) + (aliases service-info:aliases set-service-info:aliases) + (port service-info:port set-service-info:port) + (protocol service-info:protocol set-service-info:protocol)) hunk ./network.scm 908 -(define-record protocol-info - name ; Protocol name - aliases ; Alternative names - number) ; Protocol number +(define-record-type type/protocol-info + (make-protocol-info name aliases number) + protocol-info? + (name protocol-info:name set-protocol-info:name) + (aliases protocol-info:aliases set-protocol-info:aliases) + (number protocol-info:number set-protocol-info:number)) hunk ./newports.scm 11 - :use-module (scsh let-opt) hunk ./procobj.scm 15 - :use-module (scsh defrec) hunk ./procobj.scm 17 - :use-module (scsh let-opt) + :use-module (ice-9 optargs) hunk ./procobj.scm 21 -) + :use-module (srfi srfi-9)) + hunk ./procobj.scm 29 +(define-record-type type/proc (%make-proc pid %status) + proc? + (pid proc:pid set-proc:pid) + (%status proc:%status set-proc:%status)) ; The cached exit status of + ; the process; #f if we + ; haven't wait(2)'d the + ; process yet. hunk ./procobj.scm 37 -(define-record proc ; A process object - pid ; Proc's pid. - (%status #f) ; The cached exit status of the process; - ; #f if we haven't wait(2)'d the process yet. - - ;; Make proc objects print like #{proc 2318}. - ((disclose p) (list "proc" (proc:pid p)))) - +(define* (make-proc pid #:optional (%status #f)) + (%make-proc pid %status)) hunk ./procobj.scm 53 -(define (pid->proc pid . maybe-probe?) - (let ((probe? (:optional maybe-probe? #f))) - (or (maybe-pid->proc pid) - (case probe? - ((#f) (error "Pid has no corresponding process object" pid)) - ((create) (let ((p (make-proc pid))) ; Install a new one. - (add-to-population! p process-table) - p)) - (else #f))))) +(define* (pid->proc pid #:optional (maybe-probe? #f)) + (or (maybe-pid->proc pid) + (case probe? + ((#f) (error "Pid has no corresponding process object" pid)) + ((create) (let ((p (make-proc pid))) ; Install a new one. + (add-to-population! p process-table) + p)) + (else #f)))) hunk ./procobj.scm 260 - (let-optionals args ((proc-group 0) (flags 0)) + (let-optional args ((proc-group 0) (flags 0)) hunk ./rdelim.scm 1 -;;; Delimited readers -;;; for guile: read-delimited and read-delimited! are implemented in guile and -;;; modified below to use scsh char-sets and multiple values. -;;; read-line is redefined below. -;;; skip-char-set isn't mentioned in the scsh manual, but is used in fr.scm. - -(define-module (scsh rdelim) - :use-module (ice-9 rdelim) - :use-module (srfi srfi-14) - :use-module (scsh rx re-high) - :use-module (scsh rx re) - :use-module (scsh rx re-syntax) - :use-module (scsh errno) - :use-module (scsh let-opt) -) - -(begin-deprecated - ;; Prevent `export' from re-exporting (ice-9 rdelim) bindings. This behaviour - ;; of `export' is deprecated and will disappear in one of the next - ;; releases. - (define read-line #f) - (define read-delimited #f) - (define read-delimited! #f) - (define %read-delimited! #f)) - -(export read-line read-paragraph read-delimited read-delimited! - %read-delimited! skip-char-set) - -(define guile-read-delimited - (module-ref (resolve-module '(ice-9 rdelim)) 'read-delimited)) -(define guile-read-delimited! - (module-ref (resolve-module '(ice-9 rdelim)) 'read-delimited!)) - -(define (read-delimited delims . args) - (let ((rv - (apply guile-read-delimited (char-set->string delims) args))) - (if (pair? rv) - (values (car rv) (cdr rv)) - rv))) - -(define (read-delimited! delims . args) - (let ((rv - (apply guile-read-delimited! (char-set->string delims) args))) - (if (pair? rv) - (values (car rv) (cdr rv)) - rv))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; These procedures run their inner I/O loop in a C primitive, so they -;;; should be quite fast. -;;; -;;; N.B.: -;;; The C primitives %READ-DELIMITED-FDPORT!/ERRNO and -;;; %SKIP-CHAR-SET-FDPORT/ERRNO rely on knowing the representation of -;;; character sets. If these are changed from their current representation, -;;; this code must be changed as well. - -;;; (read-delimited delims [port delim-action]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Returns a string or the EOF object. DELIM-ACTION determines what to do -;;; with the terminating delimiter: -;;; - PEEK -;;; Leave it in the input stream for later reading. -;;; - TRIM (the default) -;;; Drop it on the floor. -;;; - CONCAT -;;; Append it to the returned string. -;;; - SPLIT -;;; Return it as a second return value. -;;; -;;; We repeatedly allocate a buffer and fill it with READ-DELIMITED! -;;; until we hit a delimiter or EOF. Each time through the loop, we -;;; double the total buffer space, so the loop terminates with a log -;;; number of reads, but uses at most double the optimal buffer space. - -;(define (read-delimited delims . args) -; (let-optionals args ((port (current-input-port)) -; (delim-action 'trim)) -; (let ((substr (lambda (s end) ; Smart substring. -; (if (= end (string-length s)) s -; (substring s 0 end)))) -; (delims (->char-set delims)) -; (gobble? (not (eq? delim-action 'peek)))) - -; ;; BUFLEN is total amount of buffer space allocated to date. -; (let lp ((strs '()) (buflen 80) (buf (make-string 80))) -; (receive (terminator num-read) -; (%read-delimited! delims buf gobble? port) -; (if terminator - -; ;; We are done. NUM-READ is either a read count or EOF. -; (let ((retval (if (and (zero? num-read) -; (eof-object? terminator) -; (null? strs)) -; terminator ; EOF -- got nothing. - -; ;; Got something. Stick all the strings -; ;; together, plus the terminator if the -; ;; client said 'CONCAT. -; (let ((s (substr buf num-read))) -; (cond ((and (eq? delim-action 'concat) -; (char? terminator)) -; (apply string-append -; (reverse `(,(string terminator) -; ,s . ,strs)))) - -; ((null? strs) s) ; Gratuitous opt. -; (else (apply string-append -; (reverse (cons s strs))))))))) -; (if (eq? delim-action 'split) -; (values retval terminator) -; retval)) - -; ;; We are not done. Loop and read in some more. -; (lp (cons buf strs) -; (+ buflen buflen) -; (make-string buflen)))))))) - - -;;; (read-delimited! delims buf [port delim-action start end]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Returns: -;;; - EOF if at end of file, and a non-zero read was requested. -;;; - Integer j if that many chars read into BUF. -;;; - #f if the buffer was filled w/o finding a delimiter. -;;; -;;; DELIM-ACTION determines what to do with the terminating delimiter; -;;; it is as in READ-DELIMITED. -;;; -;;; In determining the return value, there is an ambiguous case: when the -;;; buffer is full, *and* the following char is a delimiter char or EOF. -;;; Ties are broken favoring termination over #f -- after filling the buffer, -;;; READ-DELIMITED! won't return #f until it has peeked one past the end -;;; of the buffer to ensure the next char doesn't terminate input (or is EOF). -;;; However, this rule is relaxed with delim-action = CONCAT -- if the buffer -;;; is full, READ-DELIMITED! won't wait around trying to peek at the following -;;; char to determine whether or not it is a delimiter char, since it doesn't -;;; have space to store the character anyway. It simply immediately returns #f; -;;; a following read can pick up the delimiter char. - -;(define (read-delimited! delims buf . args) ; [port delim-action start end] -; (let-optionals args ((port (current-input-port)) -; (delim-action 'trim) -; (start 0) -; (end (string-length buf))) -; (receive (terminator num-read) -; (%read-delimited! delims buf -; (not (eq? delim-action 'peek)) ;Gobble delim? -; port -; start -; (if (eq? delim-action 'concat) -; (- end 1) ; Room for terminator. -; end)) - -; (if terminator ; Check for buffer overflow. -; (let ((retval (if (and (zero? num-read) -; (eof-object? terminator)) -; terminator ; EOF -- got nothing. -; num-read))) ; Got something. - -; (case delim-action -; ((peek trim) retval) -; ((split) (values retval terminator)) -; ((concat) (cond ((char? terminator) -; (string-set! buf (+ start num-read) terminator) -; (+ num-read 1)) -; (else retval))))) - -; ;; Buffer overflow. -; (case delim-action -; ((peek trim) #f) -; ((split) (values #f #f)) -; ((concat) (let ((last (read-char port))) -; (if (char? last) -; (string-set! buf (+ start num-read) last)) -; (and (or (eof-object? last) -; (char-set-contains? (->char-set delims) -; last)) -; (+ num-read 1))))))))) - - -(define guile-%read-delimited! - (module-ref (resolve-module '(ice-9 rdelim)) '%read-delimited!)) - -(define (%read-delimited! delims buf gobble? . rest) - (let ((rv (apply guile-%read-delimited! (char-set->string delims) - buf gobble? rest))) - (values (car rv) (cdr rv)))) - -;;; (%read-delimited! delims buf gobble? [port start end]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; This low-level routine uses a different interface. It returns two values: -;;; - TERMINATOR: A value describing why the read was terminated: -;;; + character or eof-object => read terminated by this value; -;;; + #f => filled buffer w/o terminating read. -;;; - NUM-READ: Number of chars read into buf. -;;; -;;; Note: -;;; - Invariant: TERMINATOR = #f => NUM-READ = END - START. -;;; - Invariant: TERMINATOR = eof-object and NUM-READ = 0 => at EOF. -;;; - When determining the TERMINATOR return value, ties are broken -;;; favoring character or the eof-object over #f. That is, if the buffer -;;; fills up, %READ-DELIMITED! will peek at one more character from the -;;; input stream to determine if it terminates the input. If so, that -;;; is returned, not #f. -;;; -;;; If GOBBLE? is true, then a terminator character is removed from -;;; the input stream. Otherwise, it is left in place for a following input -;;; operation. - -;(define (%read-delimited! delims buf gobble? . args) -; (let-optionals args ((port (current-input-port)) -; (start 0) -; (end (string-length buf))) - -; (check-arg input-port? port %read-delimited!) ; Arg checking. -; (check-arg char-set? delims %read-delimited!) ; Required, since -; (if (bogus-substring-spec? buf start end) ; we're calling C. -; (error "Illegal START/END substring indices" -; buf start end %read-delimited!)) - -; (let* ((delims (->char-set delims)) -; (sdelims (char-set:s delims))) - - -; (if (fdport? port) - -; ;; Direct C support for Unix file ports -- zippy quick. -; (let lp ((start start) (total 0)) -; (receive (terminator num-read) -; (%read-delimited-fdport!/errno sdelims buf gobble? -; port start end) -; (let ((total (+ num-read total))) -; (cond ((not (integer? terminator)) (values terminator total)) -; ((= terminator errno/intr) (lp (+ start num-read) total)) -; (else (errno-error terminator %read-delimited! -; num-read total -; delims buf gobble? port start end)))))) - -; ;; This is the code for other kinds of ports. -; ;; Mighty slow -- we read each char twice (peek first, then read). -; (let lp ((i start)) -; (let ((c (peek-char port))) -; (cond ((or (eof-object? c) ; Found terminating char or eof -; (char-set-contains? delims c)) -; (if gobble? (read-char port)) -; (values c (- i start))) - -; ((>= i end) ; Filled the buffer. -; (values #f (- i start))) - -; (else (string-set! buf i (read-char port)) -; (lp (+ i 1)))))))))) - - -;(foreign-source -; "#include " -; "" -; "/* Make sure foreign-function stubs interface to the C funs correctly: */" -; "#include \"fdports1.h\"" -; "" "") - -;(define-foreign %read-delimited-fdport!/errno (read_delim (string delims) -; (var-string buf) -; (bool gobble?) -; (desc port) -; (fixnum start) -; (fixnum end)) -; desc ; int => errno; char => terminating char; eof-object; #f => buf ovflow -; fixnum) ; number of chars read into BUF. - - -;(define-foreign %skip-char-set-fdport/errno (skip_chars (string skip-set) -; (desc port)) -; desc ; int => errno; #f => win. -; fixnum) ; number of chars skipped. - - -(define (skip-char-set skip-chars . maybe-port) - (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)) - -; ;; Direct C support for Unix file ports -- zippy quick. -; ((fdport? port) -; (let lp ((total 0)) -; (receive (err num-read) (%skip-char-set-fdport/errno scset port) -; (let ((total (+ total num-read))) -; (cond ((not err) total) -; ((= errno/intr err) (lp total)) -; (errno-error err skip-char-set cset port total)))))) - - ;; This is the code for other kinds of ports. - ;; Mighty slow -- we read each char twice (peek first, then read). - (else (let lp ((i 0)) - (let ((c (peek-char port))) - (cond ((and (char? c) (char-set-contains? cset c)) - (read-char port) - (lp (+ i 1))) - (else i)))))))) - - - - -;;; (read-line [port delim-action]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Read in a line of data. Input is terminated by either a newline or EOF. -;;; The newline is trimmed from the string by default. - -(define charset:newline (char-set #\newline)) - -(define (read-line . rest) (apply read-delimited charset:newline rest)) - - -;;; (read-paragraph [port handle-delim]) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define blank-line-regexp (rx bos (* white) #\newline eos)) - -(define (read-paragraph . args) - (let-optionals args ((port (current-input-port)) - (handle-delim 'trim)) - ;; First, skip all blank lines. - (let lp () - (let ((line (read-line port 'concat))) - (cond ((eof-object? line) - (if (eq? handle-delim 'split) (values line line) line)) - - ((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-search? blank-line-regexp line))) - - (lp (cons line lines)) - - ;; Return the paragraph - (let ((->str (lambda (lns) (apply string-append (reverse lns))))) - (case handle-delim - ((trim) (->str lines)) - - ((concat) - (->str (if (eof-object? line) lines (cons line lines)))) - - ((split) - (values (->str lines) line)) - - (else (error "Illegal HANDLE-DELIM parameter to READ-PARAGRAPH"))))))))))))) rmfile ./rdelim.scm hunk ./rw.scm 9 - :use-module (scsh let-opt) -) + :use-module (ice-9 optargs)) + hunk ./rw.scm 57 - (let-optionals args ((fd/port (current-input-port)) + (let-optional args ((fd/port (current-input-port)) hunk ./rw.scm 89 - (let-optionals args ((fd/port (current-output-port)) + (let-optional args ((fd/port (current-output-port)) hunk ./scsh.scm 15 - :use-module (scsh let-opt) + :use-module (ice-9 optargs) hunk ./scsh.scm 22 - :use-module (scsh rdelim) + :use-module (ice-9 rdelim) hunk ./stringcoll.scm 31 - :use-module (scsh defrec) -) + #:use-module (srfi srfi-9)) + hunk ./stringcoll.scm 36 -(define-record string-collector - (len 0) ; How many chars have we accumulated? - (chunks '()) ; The chunk list. - (chunk #f) ; The current chunk being filled, if any. - (chunk-left 0)) ; How many chars left to fill in the current chunk. +(define-record-type type/string-collector + (%make-string-collector len chunks chunk chunk-left) + string-collector? + (len string-collector:len set-string-collector:len) ; How many chars + ; have we + ; accumulated? + (chunks string-collector:chunks set-string-collector:chunks) ; The chunk list. + (chunk string-collector:chunk set-string-collector:chunk) ; The + ; current + ; chunk + ; being + ; filled, + ; if any. + (chunk-left string-collector:chunk-left set-string-collector:chunk-left)) + ; How many chars left to fill + ; in the current chunk. + +(define* (make-string-collector #:optional (len 0) (chunks (list)) + (chunk #f) (chunk-left 0)) + (%make-string-collector len chunks chunk chunk-left)) hunk ./syscalls.scm 12 - :use-module (scsh let-opt) + :use-module (ice-9 optargs) hunk ./syscalls.scm 14 - :use-module (scsh defrec) hunk ./syscalls.scm 16 -) + :use-module (srfi srfi-9)) hunk ./syscalls.scm 469 - -(define-record file-info - type - device - inode - mode - nlinks - uid - gid - size - atime - mtime - ctime - ) +(define-record-type type/file-info + (make-file-info type device inode mode nlinks uid gid size atime mtime ctime) + file-info? + (type file-info:type set-file-info:type) + (device file-info:device set-file-info:device) + (inode file-info:inode set-file-info:inode) + (mode file-info:mode set-file-info:mode) + (nlinks file-info:nlinks set-file-info:nlinks) + (uid file-info:uid set-file-info:uid) + (gid file-info:gid set-file-info:gid) + (size file-info:size set-file-info:size) + (atime file-info:atime set-file-info:atime) + (mtime file-info:mtime set-file-info:mtime) + (ctime file-info:ctime set-file-info:ctime)) hunk ./syscalls.scm 719 -(define-record user-info - name uid gid home-dir shell - - ;; Make user-info records print like #{user-info shivers}. - ((disclose ui) - (list "user-info" (user-info:name ui)))) +(define-record-type type/user-info + (make-user-info name uid gid home-dir shell) + user-info? + (name user-info:name set-user-info:name) + (uid user-info:uid set-user-info:uid) + (gid user-info:gid set-user-info:gid) + (home-dir user-info:home-dir set-user-info:home-dir) + (shell user-info:shell set-user-info:shell)) hunk ./syscalls.scm 767 -(define-record group-info - name gid members - - ;; Make group-info records print like #{group-info wheel}. - ((disclose gi) (list "group-info" (group-info:name gi)))) +(define-record-type type/group-info + (make-group-info name gid members) + group-info? + (name group-info:name set-group-info:name) + (gid group-info:gid set-group-info:gid) + (members group-info:members set-group-info:members)) hunk ./syscalls.scm 822 - (let-optionals args ((dir ".") + (let-optional args ((dir ".") hunk ./time.scm 6 - :use-module (scsh defrec) - :use-module (scsh let-opt) hunk ./time.scm 7 - :use-module (ice-9 receive) -) + :use-module (ice-9 receive)) + hunk ./time.scm 36 - 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 - hunk ./time.scm 68 -(define-record %date ; A Posix tm struct - seconds ; Seconds after the minute (0-59) - minute ; Minutes after the hour (0-59) - hour ; Hours since midnight (0-23) - month-day ; Day of the month (1-31) - month ; Months since January (0-11) - year ; Years since 1900 - tz-name ; Time zone as a string. - tz-secs ; Time zone as an integer: seconds west of UTC. - summer? ; Summer time (Daylight savings) in effect? - week-day ; Days since Sunday (0-6) ; Redundant - year-day) ; Days since Jan. 1 (0-365) ; Redundant +(define-record-type type/%date + (make-%date seconds minute hour month-day month year tz-name tz-secs summer? week-day year-day) + %date? + (seconds %date:seconds set-%date:seconds) + (minute %date:minute set-%date:minute) + (hour %date:hour set-%date:hour) + (month-day %date:month-day set-%date:month-day) + (month %date:month set-%date:month) + (year %date:year set-%date:year) + (tz-name %date:tz-name set-%date:tz-name) + (tz-secs %date:tz-secs set-%date:tz-secs) + (summer? %date:summer? set-%date:summer?) + (week-day %date:week-day set-%date:week-day) + (year-day %date:year-day set-%date:year-day)) hunk ./time.scm 109 -(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))) - +(define* (make-date s mi h md mo y + #:optional (tzn #f) (tzs #f) (s? #f) (wd 0) (yd 0)) + (make-%date s mi h md mo y tzn tzs s? wd yd)) hunk ./utilities.scm 12 - check-arg conjoin disjoin negate compose call/cc + check-arg conjoin disjoin negate compose hunk ./utilities.scm 178 -(define call/cc call-with-current-continuation) -