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.
This commit is contained in:
olin-shivers 2001-03-11 04:11:11 +00:00
parent 5e769973cd
commit 120a664a86
1 changed files with 537 additions and 154 deletions

View File

@ -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)
;;;
;;; 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.
;;; 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).
;;;
;;; 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.
;;; 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))
;;; (:optional :syntax))
;;;
;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
;;; explicit-renaming low-level macro system. You'll have to do some work to
;;; port it to another macro system.
;;;
;;; The :OPTIONAL macro is defined with simple high-level macros,
;;; and should be portable to any R4RS system.
;;;
;;; These macros are all careful to evaluate their default forms *only* if
;;; their values are needed.
;;;
;;; The LET-OPTIONALS expander is pretty hairy. Sorry. It does produce
;;; very good code.
;;;
;;; The top-level forms in this file are Scheme 48 module expressions.
;;; I use the module system to help me break up the expander code for
;;; LET-OPTIONALS into three procedures, which makes it easier to understand
;;; and test. But if you wanted to port this code to a module-less Scheme
;;; system, you'd probably have to inline the auxiliary procs into the actual
;;; macro definition.
;;;
;;; To repeat: This code is not simple Scheme code; it is module code.
;;; It must be loaded into the Scheme 48 ,config package, not the ,user
;;; package.
;;;
;;; The only non-R4RS dependencies in the macros are ERROR
;;; 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,130 +70,385 @@
;;; 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 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.
;;;
;;; 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.
;;; - 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,
;;;
;;; 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-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 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))))))))
(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 (NULL? REST) (PORT-DEF) ...) tree above.
(define (make-if-tree vars defaulters body-proc rest rename)
;;; 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))
(%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))
(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)))
`(,%if (,%null? ,rest)
(,(car defaulters) . ,(reverse non-defaults))
(,%let ((,v (,%car ,rest))
(,rest (,%cdr ,rest)))
,(recur (cdr vars)
(cdr defaulters)
(cons v non-defaults)))))))))
(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))
(defaulter-names (map (lambda (var) (rename (prefix-sym "def-" var)))
vars))
(prefix-sym (lambda (prefix sym)
(string->symbol (string-append prefix (symbol->string sym))))))
(defaulters (make-default-procs vars2 body-proc
defaulter-names defs rename))
(if-tree (make-if-tree vars2 defaulter-names body-proc
rest-var rename)))
(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?))
`(,%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
@ -188,13 +464,13 @@
(begin
;;; (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 ...)
(define-syntax let-optionals expand-let-optionals)
(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
@ -205,61 +481,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)))))))
(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)))))
;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
)) ; 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.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; 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-structure slow-simple-let-opt (export (let-optionals* :syntax))
(open scheme)
(begin
(define-syntax let-optionals*
(syntax-rules ()
((let-optionals* args vars&defaults body1 ...)
(let ((rest args))
(really-let-optionals* rest vars&defaults body1 ...)))))
((let-optionals* arg (opt-clause ...) body ...)
(let ((rest arg))
(let-optionals* rest (opt-clause ...) body ...)))))
(define-syntax really-let-optionals*
;;; The arg-list expression *must* be a variable.
;;; (Or must be side-effect-free, in any event.)
(define-syntax %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 ...))))
((%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 ...))))
;; 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 ...))))
;; 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 ...))))
((%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