;;; -*- mode: scheme; coding: utf-8; -*-
-;;;; Copyright (C) 2009, 2010, 2011
-;;;; Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
(define (make-formals n)
(map (lambda (i)
(datum->syntax
- x
+ x
(string->symbol
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
;;; module-ref: 14468
;;; define: 1259
;;; toplevel-set: 328
-;;; dynwind: 162
-;;; with-fluids: 0
;;; call/cc: 0
;;; module-set: 0
;;;
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
- (and alt
+ (and alt ; (body docstring nreq ...)
(let* ((body (car alt))
- (nreq (cadr alt))
- (rest (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+ (spec (cddr alt))
+ (nreq (car spec))
+ (rest (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt (if tail (car tail) 0))
(kw (and tail (cadr tail)))
(inits (if tail (caddr tail) '()))
(define (set-procedure-arity! proc)
(let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
(if (not alt)
- (set-procedure-minimum-arity! proc nreq nopt rest?)
- (let* ((nreq* (cadr alt))
- (rest?* (if (null? (cddr alt)) #f (caddr alt)))
- (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+ (begin
+ (set-procedure-property! proc 'arglist
+ (list nreq
+ nopt
+ (if kw (cdr kw) '())
+ (and kw (car kw))
+ (and rest? '_)))
+ (set-procedure-minimum-arity! proc nreq nopt rest?))
+ (let* ((spec (cddr alt))
+ (nreq* (car spec))
+ (rest?* (if (null? (cdr spec)) #f (cadr spec)))
+ (tail (and (pair? (cdr spec)) (pair? (cddr spec)) (cddr spec)))
(nopt* (if tail (car tail) 0))
(alt* (and tail (cadddr tail))))
(if (or (< nreq* nreq)
(1- nopt) args (cdr inits))
(lp (cons (car args) env)
(1- nopt) (cdr args) (cdr inits)))))
- ;; With keywords, we stop binding optionals at the first
- ;; keyword.
(let lp ((env env)
(nopt* nopt)
(args args)
(inits inits))
- (if (> nopt* 0)
- (if (or (null? args) (keyword? (car args)))
- (lp (cons (eval (car inits) env) env)
- (1- nopt*) args (cdr inits))
- (lp (cons (car args) env)
- (1- nopt*) (cdr args) (cdr inits)))
- ;; Finished with optionals.
- (let* ((aok (car kw))
- (kw (cdr kw))
- (kw-base (+ nopt nreq (if rest? 1 0)))
- (imax (let lp ((imax (1- kw-base)) (kw kw))
- (if (null? kw)
- imax
- (lp (max (cdar kw) imax)
- (cdr kw)))))
- ;; Fill in kwargs with "undefined" vals.
- (env (let lp ((i kw-base)
- ;; Also, here we bind the rest
- ;; arg, if any.
- (env (if rest? (cons args env) env)))
- (if (<= i imax)
- (lp (1+ i) (cons unbound-arg env))
- env))))
- ;; Now scan args for keywords.
- (let lp ((args args))
- (if (and (pair? args) (pair? (cdr args))
- (keyword? (car args)))
- (let ((kw-pair (assq (car args) kw))
- (v (cadr args)))
- (if kw-pair
- ;; Found a known keyword; set its value.
- (list-set! env (- imax (cdr kw-pair)) v)
- ;; Unknown keyword.
- (if (not aok)
- (scm-error 'keyword-argument-error
- "eval" "Unrecognized keyword"
- '() #f)))
- (lp (cddr args)))
- (if (pair? args)
- (if rest?
- ;; Be lenient parsing rest args.
- (lp (cdr args))
- (scm-error 'keyword-argument-error
- "eval" "Invalid keyword"
- '() #f))
- ;; Finished parsing keywords. Fill in
- ;; uninitialized kwargs by evalling init
- ;; expressions in their appropriate
- ;; environment.
- (let lp ((i (- imax kw-base))
- (inits inits))
- (if (pair? inits)
- (let ((tail (list-tail env i)))
- (if (eq? (car tail) unbound-arg)
- (set-car! tail
- (eval (car inits)
- (cdr tail))))
- (lp (1- i) (cdr inits)))
- ;; Finally, eval the body.
- (eval body env)))))))))))))))
+ (cond
+ ;; With keywords, we stop binding optionals at the
+ ;; first keyword.
+ ((> nopt* 0)
+ (if (or (null? args) (keyword? (car args)))
+ (lp (cons (eval (car inits) env) env)
+ (1- nopt*) args (cdr inits))
+ (lp (cons (car args) env)
+ (1- nopt*) (cdr args) (cdr inits))))
+ ;; Finished with optionals.
+ ((and alt (pair? args) (not (keyword? (car args)))
+ (not rest?))
+ ;; Too many positional args, no #:rest arg,
+ ;; and we have an alternate.
+ (apply alt-proc %args))
+ (else
+ (let* ((aok (car kw))
+ (kw (cdr kw))
+ (kw-base (+ nopt nreq (if rest? 1 0)))
+ (imax (let lp ((imax (1- kw-base)) (kw kw))
+ (if (null? kw)
+ imax
+ (lp (max (cdar kw) imax)
+ (cdr kw)))))
+ ;; Fill in kwargs with "undefined" vals.
+ (env (let lp ((i kw-base)
+ ;; Also, here we bind the rest
+ ;; arg, if any.
+ (env (if rest?
+ (cons args env)
+ env)))
+ (if (<= i imax)
+ (lp (1+ i) (cons unbound-arg env))
+ env))))
+ ;; Now scan args for keywords.
+ (let lp ((args args))
+ (if (and (pair? args) (pair? (cdr args))
+ (keyword? (car args)))
+ (let ((kw-pair (assq (car args) kw))
+ (v (cadr args)))
+ (if kw-pair
+ ;; Found a known keyword; set its value.
+ (list-set! env
+ (- imax (cdr kw-pair)) v)
+ ;; Unknown keyword.
+ (if (not aok)
+ (scm-error
+ 'keyword-argument-error
+ "eval" "Unrecognized keyword"
+ '() (list (car args)))))
+ (lp (cddr args)))
+ (if (pair? args)
+ (if rest?
+ ;; Be lenient parsing rest args.
+ (lp (cdr args))
+ (scm-error 'keyword-argument-error
+ "eval" "Invalid keyword"
+ '() (list (car args))))
+ ;; Finished parsing keywords. Fill in
+ ;; uninitialized kwargs by evalling init
+ ;; expressions in their appropriate
+ ;; environment.
+ (let lp ((i (- imax kw-base))
+ (inits inits))
+ (if (pair? inits)
+ (let ((tail (list-tail env i)))
+ (if (eq? (car tail) unbound-arg)
+ (set-car! tail
+ (eval (car inits)
+ (cdr tail))))
+ (lp (1- i) (cdr inits)))
+ ;; Finally, eval the body.
+ (eval body env))))))))))))))))
;; The "engine". EXP is a memoized expression.
(define (eval exp env)
(eval body new-env)
(lp (cdr inits)
(cons (eval (car inits) env) new-env)))))
-
- (('lambda (body nreq . tail))
- (if (null? tail)
- (make-fixed-closure eval nreq body (capture-env env))
- (if (null? (cdr tail))
- (make-general-closure (capture-env env) body nreq (car tail)
- 0 #f '() #f)
- (apply make-general-closure (capture-env env) body nreq tail))))
+
+ (('lambda (body docstring nreq . tail))
+ (let ((proc
+ (if (null? tail)
+ (make-fixed-closure eval nreq body (capture-env env))
+ (if (null? (cdr tail))
+ (make-general-closure (capture-env env) body
+ nreq (car tail)
+ 0 #f '() #f)
+ (apply make-general-closure (capture-env env)
+ body nreq tail)))))
+ (when docstring
+ (set-procedure-property! proc 'documentation docstring))
+ proc))
(('seq (head . tail))
(begin
env))))
(eval x env)))
- (('dynwind (in exp . out))
- (dynamic-wind (eval in env)
- (lambda () (eval exp env))
- (eval out env)))
-
- (('with-fluids (fluids vals . exp))
- (let* ((fluids (map (lambda (x) (eval x env)) fluids))
- (vals (map (lambda (x) (eval x env)) vals)))
- (let lp ((fluids fluids) (vals vals))
- (if (null? fluids)
- (eval exp env)
- (with-fluids (((car fluids) (car vals)))
- (lp (cdr fluids) (cdr vals)))))))
-
- (('prompt (tag exp . handler))
- (@prompt (eval tag env)
- (eval exp env)
- (eval handler env)))
+ (('call-with-prompt (tag thunk . handler))
+ (call-with-prompt
+ (eval tag env)
+ (eval thunk env)
+ (eval handler env)))
(('call/cc proc)
(call/cc (eval proc env)))
HCoop / bpt / guile.git / blobdiff