[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
guile/guile-scsh ChangeLog INCOMPAT USAGE alt-s...
|
From: |
Gary Houston |
|
Subject: |
guile/guile-scsh ChangeLog INCOMPAT USAGE alt-s... |
|
Date: |
Sat, 04 Aug 2001 03:26:38 -0700 |
CVSROOT: /cvs
Module name: guile
Changes by: Gary Houston <address@hidden> 01/08/04 03:26:38
Modified files:
guile-scsh : ChangeLog INCOMPAT USAGE alt-syntax.scm
fileinfo.scm fr.scm glob.scm let-opt.scm
Log message:
* glob.scm, fr.scm, fileinfo.scm, let-opt.scm:
upgraded with scsh 0.5.2 -> scsh 0.5.3 changes.
* fr.scm, glob.scm: don't use module (scsh cset-obsolete).
* let-opt.scm: don't export really-let-optionals*, it's gone.
commented out the last part the file to avoid 2nd let-optionals*
definition, which doesn't work in Guile. use module (ice-9 receive).
* alt-syntax.scm: re-export syntax-error: a kludge to allow
define-syntax macro expansion to use it.
CVSWeb URLs:
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/ChangeLog.diff?cvsroot=OldCVS&tr1=1.71&tr2=1.72&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/INCOMPAT.diff?cvsroot=OldCVS&tr1=1.23&tr2=1.24&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/USAGE.diff?cvsroot=OldCVS&tr1=1.19&tr2=1.20&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/alt-syntax.scm.diff?cvsroot=OldCVS&tr1=1.3&tr2=1.4&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/fileinfo.scm.diff?cvsroot=OldCVS&tr1=1.4&tr2=1.5&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/fr.scm.diff?cvsroot=OldCVS&tr1=1.4&tr2=1.5&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/glob.scm.diff?cvsroot=OldCVS&tr1=1.4&tr2=1.5&r1=text&r2=text
http://savannah.gnu.org/cgi-bin/viewcvs/guile/guile-scsh/let-opt.scm.diff?cvsroot=OldCVS&tr1=1.5&tr2=1.6&r1=text&r2=text
Patches:
Index: guile/guile-scsh/ChangeLog
diff -u guile/guile-scsh/ChangeLog:1.71 guile/guile-scsh/ChangeLog:1.72
--- guile/guile-scsh/ChangeLog:1.71 Wed Aug 1 14:49:58 2001
+++ guile/guile-scsh/ChangeLog Sat Aug 4 03:26:37 2001
@@ -1,3 +1,16 @@
+2001-08-03 Gary Houston <address@hidden>
+
+ * glob.scm, fr.scm, fileinfo.scm, let-opt.scm:
+ upgraded with scsh 0.5.2 -> scsh 0.5.3 changes.
+
+ * fr.scm, glob.scm: don't use module (scsh cset-obsolete).
+ * let-opt.scm: don't export really-let-optionals*, it's gone.
+ commented out the last part the file to avoid 2nd let-optionals*
+ definition, which doesn't work in Guile. use module (ice-9 receive).
+
+ * alt-syntax.scm: re-export syntax-error: a kludge to allow
+ define-syntax macro expansion to use it.
+
2001-08-01 Gary Houston <address@hidden>
* char-p.scm: new file, for new module (scsh char-p).
Index: guile/guile-scsh/INCOMPAT
diff -u guile/guile-scsh/INCOMPAT:1.23 guile/guile-scsh/INCOMPAT:1.24
--- guile/guile-scsh/INCOMPAT:1.23 Tue Jun 12 14:38:44 2001
+++ guile/guile-scsh/INCOMPAT Sat Aug 4 03:26:37 2001
@@ -8,9 +8,13 @@
scsh features not implemented
=============================
+The ODBC interface.
+
enabled-interrupts, interrupt-set, itimer, %set-unix-signal-handler,
set-enabled-interrupts, %unix-signal-handler,
with-enabled-interrupts*.
+
+(incomplete, more below.)
Bugs in scsh fixed in guile-scsh
================================
Index: guile/guile-scsh/USAGE
diff -u guile/guile-scsh/USAGE:1.19 guile/guile-scsh/USAGE:1.20
--- guile/guile-scsh/USAGE:1.19 Wed Aug 1 13:42:57 2001
+++ guile/guile-scsh/USAGE Sat Aug 4 03:26:37 2001
@@ -174,8 +174,9 @@
(regexp-fold regexp-fold-right regexp-for-each)
(scsh rx re-syntax)
-;; rx macro generates code that requires
-;; (scsh rx re)
+;; rx macro generates code that requires at least:
+;; (scsh rx re) (srfi srfi-14) (scsh cset-obsolete)
+;; (scsh cset-obsolete only needed until rx upgraded to 0.5.3.
(sre-form? expand-rx if-sre-form rx)
(scsh rx parse)
Index: guile/guile-scsh/alt-syntax.scm
diff -u guile/guile-scsh/alt-syntax.scm:1.3 guile/guile-scsh/alt-syntax.scm:1.4
--- guile/guile-scsh/alt-syntax.scm:1.3 Sun Oct 15 13:14:50 2000
+++ guile/guile-scsh/alt-syntax.scm Sat Aug 4 03:26:37 2001
@@ -5,6 +5,9 @@
:use-module (scsh signals))
(export-syntax define-syntax syntax-rules)
+;; kludge: may appear in define-syntax expansion.
+(re-export syntax-error)
+
; This definition of define-syntax is appropriate for Scheme-to-C.
;(define-macro define-syntax
Index: guile/guile-scsh/fileinfo.scm
diff -u guile/guile-scsh/fileinfo.scm:1.4 guile/guile-scsh/fileinfo.scm:1.5
--- guile/guile-scsh/fileinfo.scm:1.4 Sat Jul 7 08:35:28 2001
+++ guile/guile-scsh/fileinfo.scm Sat Aug 4 03:26:37 2001
@@ -67,7 +67,7 @@
(let ((uid (user-effective-uid)))
(with-errno-handler ((err data)
((errno/acces) 'search-denied)
- ((errno/notdir) 'not-directory)
+ ((errno/notdir) 'no-directory)
;; If the file doesn't exist, we usually return
;; 'nonexistent, but we special-case writability
Index: guile/guile-scsh/fr.scm
diff -u guile/guile-scsh/fr.scm:1.4 guile/guile-scsh/fr.scm:1.5
--- guile/guile-scsh/fr.scm:1.4 Wed Aug 1 13:42:57 2001
+++ guile/guile-scsh/fr.scm Sat Aug 4 03:26:37 2001
@@ -11,7 +11,10 @@
:use-module (ice-9 receive)
:use-module (scsh let-opt)
:use-module (srfi srfi-14)
+
+ ;; can be removed when rx upgraded to 0.5.3
:use-module (scsh cset-obsolete)
+
:use-module (scsh rdelim)
:use-module (scsh rx re)
:use-module (scsh rx re-low)
@@ -332,7 +335,7 @@
s)))
((concat) ; CONCAT-delimiter reader.
- (let ((not-delims (char-set-invert delims)))
+ (let ((not-delims (char-set-complement delims)))
(lambda maybe-port
(let* ((p (:optional maybe-port (current-input-port)))
(s (read-delimited delims p 'concat)))
@@ -342,7 +345,7 @@
(string-append s extra-delims))))))))
((split) ; SPLIT-delimiter reader.
- (let ((not-delims (char-set-invert delims)))
+ (let ((not-delims (char-set-complement delims)))
(lambda maybe-port
(let ((p (:optional maybe-port (current-input-port))))
(receive (s delim) (read-delimited delims p 'split)
Index: guile/guile-scsh/glob.scm
diff -u guile/guile-scsh/glob.scm:1.4 guile/guile-scsh/glob.scm:1.5
--- guile/guile-scsh/glob.scm:1.4 Wed Aug 1 13:42:57 2001
+++ guile/guile-scsh/glob.scm Sat Aug 4 03:26:37 2001
@@ -16,7 +16,6 @@
:use-module (scsh rx re)
:use-module (scsh utilities)
:use-module (srfi srfi-14)
- :use-module (scsh cset-obsolete)
:use-module (scsh scsh-condition)
:use-module (scsh syscalls)
)
@@ -119,7 +118,7 @@
(res (list re-bos))
(i 0))
(if (= i pat-len)
- (re-seq (reverse (str-cons chars res)))
+ (re-seq (reverse (cons re-eos (str-cons chars res))))
(let ((c (string-ref pat i))
(i (+ i 1)))
@@ -136,10 +135,9 @@
(cons re-any (str-cons chars res))
i))
- ((#\[) (receive (cset i) (parse-glob-bracket pat i)
+ ((#\[) (receive (re i) (parse-glob-bracket pat i)
(lp '()
- (cons (re-char-set cset)
- (str-cons chars res))
+ (cons re (str-cons chars res))
i)))
(else (lp (cons c chars) res i))))))))))
@@ -165,16 +163,15 @@
(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
+ (if (char? elt)
+ (char-set-adjoin! cset elt)
+ (ucs-range->char-set! (char->ascii
(car elt))
+ (+ 1
(char->ascii (cdr elt)))
+ #f cset)))
+ (char-set-copy char-set:empty)
elts)))
(values (re-char-set (if negate?
- (char-set-invert cset)
+ (char-set-complement! cset)
cset))
i)))
Index: guile/guile-scsh/let-opt.scm
diff -u guile/guile-scsh/let-opt.scm:1.5 guile/guile-scsh/let-opt.scm:1.6
--- guile/guile-scsh/let-opt.scm:1.5 Sun Jul 22 10:54:26 2001
+++ guile/guile-scsh/let-opt.scm Sat Aug 4 03:26:37 2001
@@ -1,45 +1,66 @@
+;;; 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 ((var1 default1) ...) . body)
-;;; (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
-;;; (:OPTIONAL rest-arg default-exp)
+;;; (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
+;;; <opt-clause> ::= (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 LET-OPTIONALS* and :OPTIONAL macros are defined with simple
-;;; high-level macros, and should be portable to any R4RS 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 three procs into the actual
+;;; system, you'd probably have to inline the auxiliary procs into the actual
;;; macro definition.
;;;
-;;; 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))
-;;;
;;; 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
+;;; 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 ((var1 default1) ...)
-;;; body
-;;; ...)
+;;; (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.
@@ -49,138 +70,392 @@
;;; 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))))
+;;; ...))
;;;
-;;; - When evaluated, the default expressions are carried out in the *outer*
-;;; environment. That is, the DEFAULTi forms do *not* see any of the VARi
-;;; bindings.
-;;;
-;;; I originally wanted to have the DEFAULTi forms get eval'd in a LET*
-;;; style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
-;;; impossible to implement without side effects or redundant conditional
-;;; tests. If I drop this requirement, I can use the efficient expansion
-;;; shown below. If you need LET* scope, use the less-efficient
-;;; LET-OPTIONALS* form defined below.
+;;; The ARG-TEST expression is evaluated in the outer scope of the LET,
+;;; plus a binding for the parameter being checked.
;;;
-;;; Example:
+;;; - 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)))
+;;; (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 <end-default>)))
-;;; (start-def (lambda (%port) (end-def %port <start-default>)))
+;;; (end-def (lambda (port start) (body port start <end-default>)))
+;;; (start-def (lambda (port) (end-def port <start-default>)))
;;; (port-def (lambda () (start-def <port-def>))))
-;;; (if (null? rest) (port-def)
-;;; (let ((%port (car rest))
-;;; (rest (cdr rest)))
-;;; (if (null? rest) (start-def %port)
-;;; (let ((%start (car rest))
-;;; (rest (cdr rest)))
-;;; (if (null? rest) (end-def %port %start)
-;;; (let ((%end (car rest))
-;;; (rest (cdr rest)))
-;;; (if (null? rest) (body %port %start %end)
-;;; (error ...)))))))))
-
+;;; (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 alt-syntax)
:use-module (scsh module-system))
-(export-syntax let-optionals let-optionals* :optional)
-;; this shouldn't be exported, but let-optionals* needs it.
-(export-syntax really-let-optionals*)
+(export-syntax let-optionals let-optionals* :optional)
-(define-structure let-opt-expanders (export expand-let-optionals)
- (open scheme)
+(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-default-procs vars body-proc defaulter-names defs rename)
- (let ((%lambda (rename 'lambda)))
- (let recur ((vars (reverse vars))
- (defaulter-names (reverse defaulter-names))
- (defs (reverse defs))
- (next-guy body-proc))
- (if (null? vars) '()
- (let ((vars (cdr vars)))
- `((,(car defaulter-names)
- (,%lambda ,(reverse vars)
- (,next-guy ,@(reverse vars) ,(car defs))))
- . ,(recur vars
- (cdr defaulter-names)
- (cdr defs)
- (car defaulter-names))))))))
-
-
-;;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
-
-(define (make-if-tree vars defaulters body-proc rest rename)
+(define (make-if-tree vars defaulters arg-tests body-proc
+ tail supvars rest-var star? rename)
(let ((%if (rename 'if))
- (%null? (rename 'null?))
+ (%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)))
+ (%cdr (rename 'cdr))
+ (make-rv (let ((g (make-gensym "%ov.")))
+ (lambda x (rename (g))))))
- (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
+ (let recur ((vars vars) (defaulters defaulters)
+ (ats arg-tests) (non-defaults '())
+ (supvars supvars) (sup-trues '()))
(if (null? vars)
- `(,%if (,%null? ,rest) (,body-proc . ,(reverse non-defaults))
- (,%error "Too many optional arguments." ,rest))
-
- (let ((v (car vars)))
- `(,%if (,%null? ,rest)
- (,(car defaulters) . ,(reverse non-defaults))
- (,%let ((,v (,%car ,rest))
- (,rest (,%cdr ,rest)))
- ,(recur (cdr vars)
- (cdr defaulters)
- (cons v non-defaults)))))))))
+ (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))))))))
-(define (expand-let-optionals exp rename compare?)
+;;; 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))
- (vars (map car var/defs))
-
- (prefix-sym (lambda (prefix sym)
- (string->symbol (string-append prefix (symbol->string
sym)))))
-
- ;; Private vars, one for each user var.
- ;; We prefix the % to help keep macro-expanded code from being
- ;; too confusing.
- (vars2 (map (lambda (v) (rename (prefix-sym "%" v)))
- vars))
-
- (defs (map cadr var/defs))
- (body-proc (rename 'body))
- ;; A private var, bound to the value of the ARG-LIST expression.
- (rest-var (rename '%rest))
+ (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)))))
- (defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
- vars))
+(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?))
- (defaulters (make-default-procs vars2 body-proc
- defaulter-names defs rename))
- (if-tree (make-if-tree vars2 defaulter-names body-proc
- rest-var rename)))
-
- `(,%let* ((,rest-var ,arg-list)
- (,body-proc (,%lambda ,vars . ,body))
- . ,defaulters)
- ,if-tree)))
)) ; erutcurts-enifed
;;; nilO- .noitnevnoc gnitekcarb sugob a ni deppart m'I !pleh !pleh
@@ -195,14 +470,14 @@
(for-syntax (open let-opt-expanders scheme))
(begin
-
-;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
-;;; The expander is defined in the code above.
-(define-syntax let-optionals expand-let-optionals)
+;;; (LET-OPTIONALS args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
+;;; (LET-OPTIONALS* args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
+(define-syntax let-optionals expand-let-optionals)
+(define-syntax let-optionals* expand-let-optionals*)
-;;; (:optional rest-arg default-exp)
+;;; (: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
@@ -213,61 +488,168 @@
;;; - 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))
- (cond ((null? maybe-arg) default-exp)
- ((null? (cdr maybe-arg)) (car maybe-arg))
- (else (error "too many optional arguments" maybe-arg)))))))
-
-
-;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
-;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
-;;; within the scope of VAR1 and VAR2, and so forth.
-;;;
-;;; - If the last form in the ((var1 default1) ...) list is not a
-;;; (VARi DEFAULTi) pair, but a simple variable REST, then it is
-;;; bound to any left-over values. For example, if we have VAR1 through
-;;; VAR7, and ARGS has 9 values, then REST will be bound to the list of
-;;; the two values of ARGS. If ARGS is too short, causing defaults to
-;;; be used, then REST is bound to '().
-;;; - If there is no REST variable, then it is an error to have excess
-;;; values in the ARGS list.
+ (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)))))
-;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
-;;; the ARGS form to be a variable.
+)) ; erutcurts-enifed
-(define-syntax let-optionals*
- (syntax-rules ()
- ((let-optionals* args vars&defaults body1 ...)
- (let ((rest args))
- (really-let-optionals* rest vars&defaults body1 ...)))))
+
+;;; 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-syntax really-let-optionals*
- (syntax-rules ()
- ;; Standard case. Do the first var/default and recurse.
- ((really-let-optionals* args ((var1 default1) etc ...)
- body1 ...)
- (call-with-values (lambda () (if (null? args)
- (values default1 '())
- (values (car args) (cdr args))))
- (lambda (var1 rest)
- (really-let-optionals* rest (etc ...)
- body1 ...))))
-
- ;; Single rest arg -- bind to the remaining rest values.
- ((really-let-optionals* args (rest) body1 ...)
- (let ((rest args)) body1 ...))
-
- ;; No more vars. Make sure there are no unaccounted-for values, and
- ;; do the body.
- ((really-let-optionals* args () body1 ...)
- (if (null? args) (begin body1 ...)
- (error "Too many optional arguments." args)))))
+; (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 ...)))
-)) ; erutcurts-enifed
+; ((defun name exp) (define name exp))))
+; )) ; erutcurts-enifed
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- guile/guile-scsh ChangeLog INCOMPAT USAGE alt-s...,
Gary Houston <=