scsh-0.6/scsh/let-opt.scm

266 lines
9.4 KiB
Scheme

;;; 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
;;; 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.
;;;
;;; 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.
;;;
;;; See below for details on each macro.
;;; -Olin
;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
;;; body
;;; ...)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This form is for binding a procedure's optional arguments to either
;;; the passed-in values or a default.
;;;
;;; The expression takes a rest list ARG-LIST and binds the VARi to
;;; the elements of the rest list. When there are no more elements, then
;;; the remaining VARi are bound to their corresponding DEFAULTi values.
;;; It is an error if there are more args than variables.
;;;
;;; - 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)))
;;; ...))
;;;
;;; 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>)))
;;; (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
;;; nilO- .noitnevnoc gnitekcarb sugob a ni deppart m'I !pleh !pleh
;;; Here is where we define the macros, using the expanders from the above
;;; package.
(define-structure let-opt (export (let-optionals :syntax)
(let-optionals* :syntax)
(:optional :syntax))
(open scheme error-package)
(for-syntax (open let-opt-expanders scheme))
(begin
;;; (LET-OPTIONALS args ((var1 default1) ...) 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
;;; in simple procedures that take a *single* optional argument. It is
;;; a macro so that the default will not be computed unless it is needed.
;;;
;;; REST-ARG is a rest list from a lambda -- e.g., R in
;;; (lambda (a b . r) ...)
;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
;;; - If REST-ARG has 1 element, return that element.
;;; - If REST-ARG has >1 element, error.
(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.
;;; 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