[[project @ 2001-08-04 10:26:37 by ghouston]
ghouston**20010804102637
 Ignore-this: 96d84b677a3d7657df06a36c4b58c8e1
 	* 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.
] hunk ./ChangeLog 1
+2001-08-03  Gary Houston  <ghouston@arglist.com>
+
+	* 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.
+
hunk ./INCOMPAT 11
+The ODBC interface.
+
hunk ./INCOMPAT 17
+(incomplete, more below.)
+
hunk ./USAGE 177
-;; 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.
hunk ./alt-syntax.scm 8
+;; kludge: may appear in define-syntax expansion.
+(re-export syntax-error)
+
hunk ./fileinfo.scm 70
-			 ((errno/notdir) 'not-directory)
+			 ((errno/notdir) 'no-directory)
hunk ./fr.scm 14
+
+  ;; can be removed when rx upgraded to 0.5.3
hunk ./fr.scm 17
+
hunk ./fr.scm 338
-	 (let ((not-delims (char-set-invert delims)))
+	 (let ((not-delims (char-set-complement delims)))
hunk ./fr.scm 348
-	 (let ((not-delims (char-set-invert delims)))
+	 (let ((not-delims (char-set-complement delims)))
hunk ./glob.scm 19
-  :use-module (scsh cset-obsolete)
hunk ./glob.scm 121
-	      (re-seq (reverse (str-cons chars res)))
+	      (re-seq (reverse (cons re-eos (str-cons chars res))))
hunk ./glob.scm 138
-		  ((#\[) (receive (cset i) (parse-glob-bracket pat i)
+		  ((#\[) (receive (re i) (parse-glob-bracket pat i)
hunk ./glob.scm 140
-			       (cons (re-char-set cset)
-				     (str-cons chars res))
+			       (cons re (str-cons chars res))
hunk ./glob.scm 166
-				     (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)
hunk ./glob.scm 174
-					    (char-set-invert cset)
+					    (char-set-complement! cset)
hunk ./let-opt.scm 1
+;;; LET-OPTIONALS macros
+;;; Copyright (c) 2001 by Olin Shivers.
+;;; See file COPYING.
+
hunk ./let-opt.scm 6
-;;; 	(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))
hunk ./let-opt.scm 33
-;;; 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.
hunk ./let-opt.scm 39
+;;; The LET-OPTIONALS expander is pretty hairy. Sorry. It does produce
+;;; very good code.
+;;;
hunk ./let-opt.scm 46
-;;; 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
hunk ./let-opt.scm 49
-;;; 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))
-;;;
hunk ./let-opt.scm 53
-;;; The only non-R4RS dependencies in the macros are ERROR 
+;;; The only non-R4RS dependencies in the macros are ERROR, RECEIVE,
hunk ./let-opt.scm 59
-;;; (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
hunk ./let-opt.scm 73
+;;; Simple example:
+;;;     (let-optionals* args ((in     (current-input-port))
+;;;                           (out    (current-output-port))
+;;;                           (nbytes (string-length s)))
+;;;       ...)
+;;;
hunk ./let-opt.scm 81
-;;; - 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.
+;;; - 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))))
+;;;         ...))
hunk ./let-opt.scm 101
-;;;   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.
+;;;
+;;; - 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,
hunk ./let-opt.scm 133
-;;; Example:
hunk ./let-opt.scm 134
-;;;   (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)))
hunk ./let-opt.scm 142
-;;;        (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>)))
hunk ./let-opt.scm 145
-;;;   (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.
hunk ./let-opt.scm 167
+  :use-module (ice-9 receive)
hunk ./let-opt.scm 170
-(export-syntax let-optionals let-optionals* :optional)
hunk ./let-opt.scm 171
-;; this shouldn't be exported, but let-optionals* needs it.
-(export-syntax really-let-optionals*)
+(export-syntax let-optionals let-optionals* :optional)
hunk ./let-opt.scm 173
-(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)
hunk ./let-opt.scm 180
+(define (make-gensym prefix)
+ (let ((counter 0))
+   (lambda ()
+     (set! counter (+ counter 1))
+     (string->symbol (string-append prefix (number->string counter))))))
+
hunk ./let-opt.scm 187
+;;; 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.
hunk ./let-opt.scm 191
+;;;
+;;; 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))))))
hunk ./let-opt.scm 223
-(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))))))))
+    ;; 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)
hunk ./let-opt.scm 268
+		  (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)))))
hunk ./let-opt.scm 277
-;;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
- 
-(define (make-if-tree vars defaulters body-proc rest rename)
+	  (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)
hunk ./let-opt.scm 290
-	(%null? (rename 'null?))
+	(%pair? (rename 'pair?))
+	(%not (rename 'not))
hunk ./let-opt.scm 294
+	(%lambda (rename 'lambda))
+	(%call/values (rename 'call-with-values))
hunk ./let-opt.scm 297
-	(%cdr (rename 'cdr)))
+	(%cdr (rename 'cdr))
+	(make-rv (let ((g (make-gensym "%ov.")))
+		   (lambda x (rename (g))))))
hunk ./let-opt.scm 301
-    (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
+    (let recur ((vars vars) (defaulters defaulters)
+		(ats arg-tests) (non-defaults '())
+		(supvars supvars) (sup-trues '()))
hunk ./let-opt.scm 305
-	  `(,%if (,%null? ,rest) (,body-proc . ,(reverse non-defaults))
-		 (,%error "Too many optional arguments." ,rest))
+	  (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))
hunk ./let-opt.scm 336
-	  (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 (,%pair? ,tail)
+		       (,%let ((,rv (,%car ,tail))
+			       (,tail (,%cdr ,tail)))
+		         . ,body)
+		       (,(car defaulters) ,@(reverse non-defaults) . ,sup-trues))))))))
hunk ./let-opt.scm 343
-(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?)
hunk ./let-opt.scm 406
-	 (vars (map car var/defs))
+
+	 (body-proc  (rename 'body))
+	 (tail-var (rename '%tail))	; Bound to remaining args to be parsed.
+
+	 (%let* (rename 'let*))
+	 (%lambda (rename 'lambda))
hunk ./let-opt.scm 414
-		       (string->symbol (string-append prefix (symbol->string sym)))))
+		       (string->symbol (string-append prefix (symbol->string sym))))))
hunk ./let-opt.scm 416
-	 ;; 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))
+    (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)))))
hunk ./let-opt.scm 433
-	 (defs (map cadr var/defs))
-	 (body-proc (rename 'body))
+	     (defaulters (make-default-procs vars body-proc defaulter-names
+					     defs rsupvars maybe-rest
+					     star? rename))
hunk ./let-opt.scm 437
-	 ;; A private var, bound to the value of the ARG-LIST expression.
-	 (rest-var (rename '%rest))
+	     (if-tree (make-if-tree vars defaulter-names arg-tests body-proc
+				    tail-var rsupvars maybe-rest star? rename))
hunk ./let-opt.scm 440
-	 (%let* (rename 'let*))
-	 (%lambda (rename 'lambda))
+	     ;; Flatten out the multi-arg items.
+	     (allvars (apply append (map (lambda (v) (if (pair? v) v
+							 (list v)))
+					 vars))))
hunk ./let-opt.scm 445
-	 (defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
-			       vars))
+	`(,%let* ((,tail-var ,arg-list)
+		  (,body-proc (,%lambda ,(append (if maybe-rest
+						     (cons maybe-rest allvars)
+						     allvars)
+						 just-supvars)
+			        . ,body))
+		  . ,defaulters)
+		 ,if-tree)))))
hunk ./let-opt.scm 454
-	 (defaulters (make-default-procs vars2 body-proc
-					 defaulter-names defs rename))
-	 (if-tree (make-if-tree vars2 defaulter-names body-proc
-				rest-var rename)))
+(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?))
hunk ./let-opt.scm 459
-    `(,%let* ((,rest-var ,arg-list)
-	      (,body-proc (,%lambda ,vars . ,body))
-	      . ,defaulters)
-       ,if-tree)))
hunk ./let-opt.scm 474
-;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
-;;; The expander is defined in the code above.
+;;; (LET-OPTIONALS  args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
+;;; (LET-OPTIONALS* args ((var1 default1 [arg-test supplied?]) ...) body1 ...)
hunk ./let-opt.scm 477
-(define-syntax let-optionals expand-let-optionals)
+(define-syntax let-optionals  expand-let-optionals)
+(define-syntax let-optionals* expand-let-optionals*)
hunk ./let-opt.scm 480
-
-;;; (:optional rest-arg default-exp)
+;;; (:optional rest-arg default-exp [test-pred])
hunk ./let-opt.scm 491
+;;;
+;;; 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.
hunk ./let-opt.scm 499
-       (cond ((null? maybe-arg) default-exp)
-	     ((null? (cdr maybe-arg)) (car maybe-arg))
-	     (else (error "too many optional arguments" maybe-arg)))))))
+       (if (pair? maybe-arg)
+	   (if (null? (cdr maybe-arg)) (car maybe-arg)
+	       (error "too many optional arguments" maybe-arg))
+	   default-exp)))
hunk ./let-opt.scm 504
+    ((: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
hunk ./let-opt.scm 517
-;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) 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.
hunk ./let-opt.scm 522
-;;; 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.
hunk ./let-opt.scm 523
+; (define-structure slow-simple-let-opt (export (let-optionals* :syntax))
+;   (open scheme)
+;   (begin
hunk ./let-opt.scm 527
-;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
-;;; the ARGS form to be a variable.
+; (define-syntax let-optionals*
+;   (syntax-rules ()
+;     ((let-optionals* arg (opt-clause ...) body ...)
+;      (let ((rest arg))
+;        (let-optionals* rest (opt-clause ...) body ...)))))
hunk ./let-opt.scm 533
-(define-syntax let-optionals*
-  (syntax-rules ()
-    ((let-optionals* args vars&defaults body1 ...)
-     (let ((rest args))
-       (really-let-optionals* rest vars&defaults body1 ...)))))
+; ;;; The arg-list expression *must* be a variable.
+; ;;; (Or must be side-effect-free, in any event.)
hunk ./let-opt.scm 536
-(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 ...))))
+; (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 ...))))
hunk ./let-opt.scm 549
-    ;; Single rest arg -- bind to the remaining rest values.
-    ((really-let-optionals* args (rest) body1 ...)
-     (let ((rest args)) body1 ...))
+;     ((%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 ...))))
hunk ./let-opt.scm 558
-    ;; 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)))))
+;     ((%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 ...))))
hunk ./let-opt.scm 567
-)) ; erutcurts-enifed
+;     ((%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