Update of /cvsroot/scsh/scsh-0.6/scsh
In directory usw-pr-cvs1:/tmp/cvs-serv13841/scsh
Modified Files:
let-opt.scm
Log Message:
New, improved let-opt. More features.
But I have a whole different design for handling optional args, so
this will all go away at some point.
Index: let-opt.scm
===================================================================
RCS file: /cvsroot/scsh/scsh-0.6/scsh/let-opt.scm,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -r1.1 -r1.2
*** let-opt.scm 1999/09/14 13:32:02 1.1
--- let-opt.scm 2001/03/11 04:11:11 1.2
***************
*** 1,6 ****
;;; 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)
;;;
;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
--- 1,29 ----
+ ;;; 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
! ;;; <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
***************
*** 8,36 ****
;;; 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.
;;;
;;; These macros are all careful to evaluate their default forms *only* if
;;; their values are needed.
;;;
;;; 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
;;; 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
;;; and CALL-WITH-VALUES.
;;;
--- 31,55 ----
;;; 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.
;;;
***************
*** 38,44 ****
;;; -Olin
! ;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
! ;;; body
! ;;; ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This form is for binding a procedure's optional arguments to either
--- 57,65 ----
;;; -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
***************
*** 50,71 ****
;;; It is an error if there are more args than variables.
;;;
;;; - The default expressions are *not* evaluated unless needed.
;;;
! ;;; - 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.
;;;
! ;;; Example:
;;; (define (read-string! str . maybe-args)
! ;;; (let-optionals maybe-args ((port (current-input-port))
! ;;; (start 0)
! ;;; (end (string-length str)))
;;; ...))
;;;
--- 71,138 ----
;;; 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)))
;;; ...))
;;;
***************
*** 73,177 ****
;;;
;;; (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>)))
;;; (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 ...)))))))))
!
!
! (define-structure let-opt-expanders (export expand-let-optionals)
! (open scheme)
(begin
;;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
;;; I wish I had a reasonable loop macro.
! (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)
(let ((%if (rename 'if))
! (%null? (rename 'null?))
(%error (rename 'error))
(%let (rename 'let))
(%car (rename 'car))
! (%cdr (rename 'cdr)))
! (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
(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)))))))))
! (define (expand-let-optionals exp 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))
(%let* (rename 'let*))
(%lambda (rename 'lambda))
! (defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
! vars))
- (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
--- 140,453 ----
;;;
;;; (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>)))
;;; (port-def (lambda () (start-def <port-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-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
***************
*** 189,199 ****
! ;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
! ;;; The expander is defined in the code above.
! (define-syntax let-optionals expand-let-optionals)
!
! ;;; (:optional rest-arg default-exp)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This form is for evaluating optional arguments and their defaults
--- 465,475 ----
! ;;; (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 [test-pred])
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This form is for evaluating optional arguments and their defaults
***************
*** 206,209 ****
--- 482,488 ----
;;; - 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
***************
*** 211,265 ****
((: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.
! ;;; This just interfaces to REALLY-LET-OPTIONALS*, which expects
! ;;; the ARGS form to be a variable.
(define-syntax let-optionals*
(syntax-rules ()
! ((let-optionals* args vars&defaults body1 ...)
! (let ((rest args))
! (really-let-optionals* rest vars&defaults body1 ...)))))
! (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)))))
)) ; erutcurts-enifed
--- 490,648 ----
((: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
|