mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 06:50:31 +02:00
Code Activity

update comments in psyntax.scm

Browse source 
* module/ice-9/psyntax.scm: Update comments. Fix a couple of needless
  conses in and-map.

* module/ice-9/psyntax-pp.scm (#{and-map*\ 35}): Regen.
This commit is contained in:
Andy Wingo 2010-08-09 21:15:18 +02:00
parent efa360afc3
commit 565c8e30cd
2 changed files with 62 additions and 133 deletions
Download patch file Download diff file Expand all files Collapse all files

6
module/ice-9/psyntax-pp.scm
View file

@ -30,10 +30,8 @@
(#{first\ 231}# (cdr #{first\ 223}#)) (#{first\ 231}# (cdr #{first\ 223}#))
(#{rest\ 232}# (map cdr #{rest\ 224}#))) (#{rest\ 232}# (map cdr #{rest\ 224}#)))
(if (null? #{first\ 231}#) (if (null? #{first\ 231}#)
(@apply #{f\ 199}# (cons #{x\ 229}# #{xr\ 230}#)) (@apply #{f\ 199}# #{x\ 229}# #{xr\ 230}#)
(if (@apply (if (@apply #{f\ 199}# #{x\ 229}# #{xr\ 230}#)
#{f\ 199}#
(cons #{x\ 229}# #{xr\ 230}#))
(#{andmap\ 222}# #{first\ 231}# #{rest\ 232}#) (#{andmap\ 222}# #{first\ 231}# #{rest\ 232}#)
#f))))))) #f)))))))
(begin (begin

187
module/ice-9/psyntax.scm
View file

@ -19,17 +19,9 @@
;;; Portable implementation of syntax-case ;;; Portable implementation of syntax-case
;;; Extracted from Chez Scheme Version 5.9f ;;; Originally extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman ;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
;;; revision control logs corresponding to this file: 2009, 2010.
;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
;;; 2000-09-12, 2001-03-08
;;; Copyright (c) 1992-1997 Cadence Research Systems ;;; Copyright (c) 1992-1997 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this ;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software ;;; software for any lawful purpose, and to redistribute this software
@ -41,15 +33,20 @@
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER. ;;; NATURE WHATSOEVER.
;;; Before attempting to port this code to a new implementation of ;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
;;; Scheme, please read the notes below carefully. ;;; to the ChangeLog distributed in the same directory as this file:
;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
;;; 2000-09-12, 2001-03-08
;;; Modified by Andy Wingo <wingo@pobox.com> according to the Git
;;; revision control logs corresponding to this file: 2009, 2010.
;;; This file defines the syntax-case expander, macroexpand, and a set ;;; This file defines the syntax-case expander, macroexpand, and a set
;;; of associated syntactic forms and procedures. Of these, the ;;; of associated syntactic forms and procedures. Of these, the
;;; following are documented in The Scheme Programming Language, ;;; following are documented in The Scheme Programming Language,
;;; Second Edition (R. Kent Dybvig, Prentice Hall, 1996). Most are ;;; Fourth Edition (R. Kent Dybvig, MIT Press, 2009), and in the
;;; also documented in the R4RS and draft R5RS. ;;; R6RS:
;;; ;;;
;;; bound-identifier=? ;;; bound-identifier=?
;;; datum->syntax ;;; datum->syntax
@ -67,9 +64,8 @@
;;; syntax-rules ;;; syntax-rules
;;; with-syntax ;;; with-syntax
;;; ;;;
;;; All standard Scheme syntactic forms are supported by the expander ;;; Additionally, the expander provides definitions for a number of core
;;; or syntactic abstractions defined in this file. Only the R4RS ;;; Scheme syntactic bindings, such as `let', `lambda', and the like.
;;; delay is omitted, since its expansion is implementation-dependent.
;;; The remaining exports are listed below: ;;; The remaining exports are listed below:
;;; ;;;
@ -87,83 +83,40 @@
;;; ($sc-dispatch e p) ;;; ($sc-dispatch e p)
;;; used by expanded code to handle syntax-case matching ;;; used by expanded code to handle syntax-case matching
;;; The following nonstandard procedures must be provided by the ;;; This file is shipped along with an expanded version of itself,
;;; implementation for this code to run using the standard portable ;;; psyntax-pp.scm, which is loaded when psyntax.scm has not yet been
;;; hooks and output constructors. They are not used by expanded code, ;;; compiled. In this way, psyntax bootstraps off of an expanded
;;; and so need be present only at expansion time. ;;; version of itself.
;;; This implementation of the expander sometimes uses syntactic
;;; abstractions when procedural abstractions would suffice. For
;;; example, we define top-wrap and top-marked? as
;;; ;;;
;;; (eval x)
;;; where x is always in the form ("noexpand" expr).
;;; returns the value of expr. the "noexpand" flag is used to tell the
;;; evaluator/expander that no expansion is necessary, since expr has
;;; already been fully expanded to core forms.
;;;
;;; eval will not be invoked during the loading of psyntax.pp. After
;;; psyntax.pp has been loaded, the expansion of any macro definition,
;;; whether local or global, will result in a call to eval. If, however,
;;; macroexpand has already been registered as the expander to be used
;;; by eval, and eval accepts one argument, nothing special must be done
;;; to support the "noexpand" flag, since it is handled by macroexpand.
;;;
;;; (gensym)
;;; returns a unique symbol each time it's called
;;; When porting to a new Scheme implementation, you should define the
;;; procedures listed above, load the expanded version of psyntax.ss
;;; (psyntax.pp, which should be available whereever you found
;;; psyntax.ss), and register macroexpand as the current expander (how
;;; you do this depends upon your implementation of Scheme). You may
;;; change the hooks and constructors defined toward the beginning of
;;; the code below, but to avoid bootstrapping problems, do so only
;;; after you have a working version of the expander.
;;; Chez Scheme allows the syntactic form (syntax <template>) to be
;;; abbreviated to #'<template>, just as (quote <datum>) may be
;;; abbreviated to '<datum>. The #' syntax makes programs written
;;; using syntax-case shorter and more readable and draws out the
;;; intuitive connection between syntax and quote.
;;; If you find that this code loads or runs slowly, consider
;;; switching to faster hardware or a faster implementation of
;;; Scheme. In Chez Scheme on a 200Mhz Pentium Pro, expanding,
;;; compiling (with full optimization), and loading this file takes
;;; between one and two seconds.
;;; In the expander implementation, we sometimes use syntactic abstractions
;;; when procedural abstractions would suffice. For example, we define
;;; top-wrap and top-marked? as
;;; (define-syntax top-wrap (identifier-syntax '((top)))) ;;; (define-syntax top-wrap (identifier-syntax '((top))))
;;; (define-syntax top-marked? ;;; (define-syntax top-marked?
;;; (syntax-rules () ;;; (syntax-rules ()
;;; ((_ w) (memq 'top (wrap-marks w))))) ;;; ((_ w) (memq 'top (wrap-marks w)))))
;;;
;;; rather than ;;; rather than
;;;
;;; (define top-wrap '((top))) ;;; (define top-wrap '((top)))
;;; (define top-marked? ;;; (define top-marked?
;;; (lambda (w) (memq 'top (wrap-marks w)))) ;;; (lambda (w) (memq 'top (wrap-marks w))))
;;; On ther other hand, we don't do this consistently; we define make-wrap, ;;;
;;; wrap-marks, and wrap-subst simply as ;;; On the other hand, we don't do this consistently; we define
;;; make-wrap, wrap-marks, and wrap-subst simply as
;;;
;;; (define make-wrap cons) ;;; (define make-wrap cons)
;;; (define wrap-marks car) ;;; (define wrap-marks car)
;;; (define wrap-subst cdr) ;;; (define wrap-subst cdr)
;;;
;;; In Chez Scheme, the syntactic and procedural forms of these ;;; In Chez Scheme, the syntactic and procedural forms of these
;;; abstractions are equivalent, since the optimizer consistently ;;; abstractions are equivalent, since the optimizer consistently
;;; integrates constants and small procedures. Some Scheme ;;; integrates constants and small procedures. This will be true of
;;; implementations, however, may benefit from more consistent use ;;; Guile as well, once we implement a proper inliner.
;;; of one form or the other.
;;; implementation information: ;;; Implementation notes:
;;; "begin" is treated as a splicing construct at top level and at
;;; the beginning of bodies. Any sequence of expressions that would
;;; be allowed where the "begin" occurs is allowed.
;;; "let-syntax" and "letrec-syntax" are also treated as splicing
;;; constructs, in violation of the R4RS appendix and probably the R5RS
;;; when it comes out. A consequence, let-syntax and letrec-syntax do
;;; not create local contours, as do let and letrec. Although the
;;; functionality is greater as it is presently implemented, we will
;;; probably change it to conform to the R4RS/expected R5RS.
;;; Objects with no standard print syntax, including objects containing ;;; Objects with no standard print syntax, including objects containing
;;; cycles and syntax object, are allowed in quoted data as long as they ;;; cycles and syntax object, are allowed in quoted data as long as they
@ -171,30 +124,23 @@
;;; Such objects are never copied. ;;; Such objects are never copied.
;;; All identifiers that don't have macro definitions and are not bound ;;; All identifiers that don't have macro definitions and are not bound
;;; lexically are assumed to be global variables ;;; lexically are assumed to be global variables.
;;; Top-level definitions of macro-introduced identifiers are allowed. ;;; Top-level definitions of macro-introduced identifiers are allowed.
;;; This may not be appropriate for implementations in which the ;;; This may not be appropriate for implementations in which the
;;; model is that bindings are created by definitions, as opposed to ;;; model is that bindings are created by definitions, as opposed to
;;; one in which initial values are assigned by definitions. ;;; one in which initial values are assigned by definitions.
;;; Top-level variable definitions of syntax keywords is not permitted.
;;; Any solution allowing this would be kludgey and would yield
;;; surprising results in some cases. We can provide an undefine-syntax
;;; form. The questions is, should define be an implicit undefine-syntax?
;;; We've decided no for now.
;;; Identifiers and syntax objects are implemented as vectors for ;;; Identifiers and syntax objects are implemented as vectors for
;;; portability. As a result, it is possible to "forge" syntax ;;; portability. As a result, it is possible to "forge" syntax objects.
;;; objects.
;;; The implementation of generate-temporaries assumes that it is possible ;;; The implementation of generate-temporaries assumes that it is
;;; to generate globally unique symbols (gensyms). ;;; possible to generate globally unique symbols (gensyms).
;;; The source location associated with incoming expressions is tracked via the ;;; The source location associated with incoming expressions is tracked
;;; source-properties mechanism, a weak map from expression to source ;;; via the source-properties mechanism, a weak map from expression to
;;; information. At times the source is separated from the expression; see the ;;; source information. At times the source is separated from the
;;; note below about "efficiency and confusion". ;;; expression; see the note below about "efficiency and confusion".
;;; Bootstrapping: ;;; Bootstrapping:
@ -226,8 +172,8 @@
(first (cdr first)) (first (cdr first))
(rest (map cdr rest))) (rest (map cdr rest)))
(if (null? first) (if (null? first)
(apply f (cons x xr)) (apply f x xr)
(and (apply f (cons x xr)) (andmap first rest))))))))) (and (apply f x xr) (andmap first rest)))))))))
(define-syntax define-expansion-constructors (define-syntax define-expansion-constructors
(lambda (x) (lambda (x)
@ -367,9 +313,7 @@
(let ((val (variable-ref v))) (let ((val (variable-ref v)))
(and (macro? val) (macro-type val) (and (macro? val) (macro-type val)
(cons (macro-type val) (cons (macro-type val)
(macro-binding val)))))))) (macro-binding val)))))))))
)
(define (decorate-source e s) (define (decorate-source e s)
@ -409,14 +353,6 @@
(maybe-name-value! name exp) (maybe-name-value! name exp)
(make-lexical-set source name var exp))) (make-lexical-set source name var exp)))
;; Before modules are booted, we can't expand into data structures from
;; (language tree-il) -- we need to give the evaluator the
;; s-expressions that it understands natively. Actually the real truth
;; of the matter is that the evaluator doesn't understand tree-il
;; structures at all. So until we fix the evaluator, if ever, the
;; conflation that we should use tree-il iff we are compiling
;; holds true.
;;
(define (analyze-variable mod var modref-cont bare-cont) (define (analyze-variable mod var modref-cont bare-cont)
(if (not mod) (if (not mod)
(bare-cont var) (bare-cont var)
@ -458,11 +394,6 @@
(maybe-name-value! var exp) (maybe-name-value! var exp)
(make-toplevel-define source var exp))) (make-toplevel-define source var exp)))
;; Ideally we would have all lambdas be case lambdas, but that would
;; need special support in the interpreter for the full capabilities
;; of case-lambda, with optional and keyword args and else clauses.
;; This will come with the new interpreter, but for now we separate
;; the cases.
(define build-simple-lambda (define build-simple-lambda
(lambda (src req rest vars meta exp) (lambda (src req rest vars meta exp)
(make-lambda src (make-lambda src
@ -636,7 +567,7 @@
(cons (cons (car labels) (car bindings)) r))))) (cons (cons (car labels) (car bindings)) r)))))
(define extend-var-env (define extend-var-env
; variant of extend-env that forms "lexical" binding ;; variant of extend-env that forms "lexical" binding
(lambda (labels vars r) (lambda (labels vars r)
(if (null? labels) (if (null? labels)
r r
@ -767,7 +698,7 @@
((_) (make-ribcage '() '() '())))) ((_) (make-ribcage '() '() '()))))
(define extend-ribcage! (define extend-ribcage!
; must receive ids with complete wraps ;; must receive ids with complete wraps
(lambda (ribcage id label) (lambda (ribcage id label)
(set-ribcage-symnames! ribcage (set-ribcage-symnames! ribcage
(cons (syntax-object-expression id) (cons (syntax-object-expression id)
@ -986,7 +917,7 @@
(define chi-when-list (define chi-when-list
(lambda (e when-list w) (lambda (e when-list w)
; when-list is syntax'd version of list of situations ;; when-list is syntax'd version of list of situations
(let f ((when-list when-list) (situations '())) (let f ((when-list when-list) (situations '()))
(if (null? when-list) (if (null? when-list)
situations situations
@ -1091,7 +1022,7 @@
((_ (name . args) e1 e2 ...) ((_ (name . args) e1 e2 ...)
(and (id? #'name) (and (id? #'name)
(valid-bound-ids? (lambda-var-list #'args))) (valid-bound-ids? (lambda-var-list #'args)))
; need lambda here... ;; need lambda here...
(values 'define-form (wrap #'name w mod) (values 'define-form (wrap #'name w mod)
(decorate-source (decorate-source
(cons #'lambda (wrap #'(args e1 e2 ...) w mod)) (cons #'lambda (wrap #'(args e1 e2 ...) w mod))
@ -1793,8 +1724,8 @@
(lvl (syntax-object-expression vars) (lvl (syntax-object-expression vars)
ls ls
(join-wraps w (syntax-object-wrap vars)))) (join-wraps w (syntax-object-wrap vars))))
; include anything else to be caught by subsequent error ;; include anything else to be caught by subsequent error
; checking ;; checking
(else (cons vars ls)))))) (else (cons vars ls))))))
;;; core transformers ;;; core transformers
@ -1865,8 +1796,8 @@
(ellipsis? #'dots) (ellipsis? #'dots)
(gen-syntax src #'e r maps (lambda (x) #f) mod)) (gen-syntax src #'e r maps (lambda (x) #f) mod))
((x dots . y) ((x dots . y)
; this could be about a dozen lines of code, except that we ;; this could be about a dozen lines of code, except that we
; choose to handle #'(x ... ...) forms ;; choose to handle #'(x ... ...) forms
(ellipsis? #'dots) (ellipsis? #'dots)
(let f ((y #'y) (let f ((y #'y)
(k (lambda (maps) (k (lambda (maps)
@ -1941,14 +1872,14 @@
(actuals (map (lambda (x) `(ref ,(car x))) map-env))) (actuals (map (lambda (x) `(ref ,(car x))) map-env)))
(cond (cond
((eq? (car e) 'ref) ((eq? (car e) 'ref)
; identity map equivalence: ;; identity map equivalence:
; (map (lambda (x) x) y) == y ;; (map (lambda (x) x) y) == y
(car actuals)) (car actuals))
((and-map ((and-map
(lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals))) (lambda (x) (and (eq? (car x) 'ref) (memq (cadr x) formals)))
(cdr e)) (cdr e))
; eta map equivalence: ;; eta map equivalence:
; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...) ;; (map (lambda (x ...) (f x ...)) y ...) == (map f y ...)
`(map (primitive ,(car e)) `(map (primitive ,(car e))
,@(map (let ((r (map cons formals actuals))) ,@(map (let ((r (map cons formals actuals)))
(lambda (x) (cdr (assq (cadr x) r)))) (lambda (x) (cdr (assq (cadr x) r))))
@ -2264,8 +2195,8 @@
(global-extend 'core 'syntax-case (global-extend 'core 'syntax-case
(let () (let ()
(define convert-pattern (define convert-pattern
; accepts pattern & keys ;; accepts pattern & keys
; returns $sc-dispatch pattern & ids ;; returns $sc-dispatch pattern & ids
(lambda (pattern keys) (lambda (pattern keys)
(define cvt* (define cvt*
(lambda (p* n ids) (lambda (p* n ids)
@ -2352,7 +2283,7 @@
(syntax-violation 'syntax-case "misplaced ellipsis" pat)) (syntax-violation 'syntax-case "misplaced ellipsis" pat))
(else (else
(let ((y (gen-var 'tmp))) (let ((y (gen-var 'tmp)))
; fat finger binding and references to temp variable y ;; fat finger binding and references to temp variable y
(build-application no-source (build-application no-source
(build-simple-lambda no-source (list 'tmp) #f (list y) '() (build-simple-lambda no-source (list 'tmp) #f (list y) '()
(let ((y (build-lexical-reference 'value no-source (let ((y (build-lexical-reference 'value no-source
@ -2419,7 +2350,7 @@
(if (and-map (lambda (x) (and (id? x) (not (ellipsis? x)))) (if (and-map (lambda (x) (and (id? x) (not (ellipsis? x))))
#'(key ...)) #'(key ...))
(let ((x (gen-var 'tmp))) (let ((x (gen-var 'tmp)))
; fat finger binding and references to temp variable x ;; fat finger binding and references to temp variable x
(build-application s (build-application s
(build-simple-lambda no-source (list 'tmp) #f (list x) '() (build-simple-lambda no-source (list 'tmp) #f (list x) '()
(gen-syntax-case (build-lexical-reference 'value no-source (gen-syntax-case (build-lexical-reference 'value no-source
@ -2454,8 +2385,8 @@
(syntax-object-module id)))) (syntax-object-module id))))
(set! syntax->datum (set! syntax->datum
; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially
; or entirely of unwrapped, nonsymbolic data ;; or entirely of unwrapped, nonsymbolic data
(lambda (x) (lambda (x)
(strip x empty-wrap))) (strip x empty-wrap)))