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

reindent psyntax.scm

Browse source 
* module/ice-9/psyntax.scm: Reindent.
This commit is contained in:
Andy Wingo 2010-08-09 21:17:57 +02:00
parent 565c8e30cd
commit 8fad25c25f
1 changed files with 2255 additions and 2257 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -156,8 +156,8 @@
(set-current-module (resolve-module '(guile)))) (set-current-module (resolve-module '(guile))))
(let () (let ()
;;; Private version of and-map that handles multiple lists. ;; Private version of and-map that handles multiple lists.
(define and-map* (define and-map*
(lambda (f first . rest) (lambda (f first . rest)
(or (null? first) (or (null? first)
(if (null? rest) (if (null? rest)
@ -175,7 +175,7 @@
(apply f x xr) (apply f x xr)
(and (apply f 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)
(syntax-case x () (syntax-case x ()
((_) ((_)
@ -193,7 +193,7 @@
out))) out)))
#`(begin #,@(reverse out)))))))) #`(begin #,@(reverse out))))))))
(define-syntax define-expansion-accessors (define-syntax define-expansion-accessors
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_ stem field ...) ((_ stem field ...)
@ -221,7 +221,7 @@
(syntax->datum #'(field ...)))) (syntax->datum #'(field ...))))
(lp (1+ n))))))))) (lp (1+ n)))))))))
(define-syntax define-structure (define-syntax define-structure
(lambda (x) (lambda (x)
(define construct-name (define construct-name
(lambda (template-identifier . args) (lambda (template-identifier . args)
@ -272,11 +272,11 @@
(vector-set! x index update))) (vector-set! x index update)))
...)))))) ...))))))
(let () (let ()
(define-expansion-constructors) (define-expansion-constructors)
(define-expansion-accessors lambda meta) (define-expansion-accessors lambda meta)
;;; hooks to nonportable run-time helpers ;; hooks to nonportable run-time helpers
(begin (begin
(define fx+ +) (define fx+ +)
(define fx- -) (define fx- -)
@ -327,7 +327,7 @@
(if (not (assq 'name meta)) (if (not (assq 'name meta))
(set-lambda-meta! val (acons 'name name meta)))))) (set-lambda-meta! val (acons 'name name meta))))))
;;; output constructors ;; output constructors
(define build-void (define build-void
(lambda (source) (lambda (source)
(make-void source))) (make-void source)))
@ -493,61 +493,61 @@
(let ((x e)) (let ((x e))
(if (not (pred? x)) (syntax-violation who "invalid argument" x)))))) (if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;;; compile-time environments ;; compile-time environments
;;; wrap and environment comprise two level mapping. ;; wrap and environment comprise two level mapping.
;;; wrap : id --> label ;; wrap : id --> label
;;; env : label --> <element> ;; env : label --> <element>
;;; environments are represented in two parts: a lexical part and a global ;; environments are represented in two parts: a lexical part and a global
;;; part. The lexical part is a simple list of associations from labels ;; part. The lexical part is a simple list of associations from labels
;;; to bindings. The global part is implemented by ;; to bindings. The global part is implemented by
;;; {put,get}-global-definition-hook and associates symbols with ;; {put,get}-global-definition-hook and associates symbols with
;;; bindings. ;; bindings.
;;; global (assumed global variable) and displaced-lexical (see below) ;; global (assumed global variable) and displaced-lexical (see below)
;;; do not show up in any environment; instead, they are fabricated by ;; do not show up in any environment; instead, they are fabricated by
;;; lookup when it finds no other bindings. ;; lookup when it finds no other bindings.
;;; <environment> ::= ((<label> . <binding>)*) ;; <environment> ::= ((<label> . <binding>)*)
;;; identifier bindings include a type and a value ;; identifier bindings include a type and a value
;;; <binding> ::= (macro . <procedure>) macros ;; <binding> ::= (macro . <procedure>) macros
;;; (core . <procedure>) core forms ;; (core . <procedure>) core forms
;;; (module-ref . <procedure>) @ or @@ ;; (module-ref . <procedure>) @ or @@
;;; (begin) begin ;; (begin) begin
;;; (define) define ;; (define) define
;;; (define-syntax) define-syntax ;; (define-syntax) define-syntax
;;; (local-syntax . rec?) let-syntax/letrec-syntax ;; (local-syntax . rec?) let-syntax/letrec-syntax
;;; (eval-when) eval-when ;; (eval-when) eval-when
;;; #'. (<var> . <level>) pattern variables ;; #'. (<var> . <level>) pattern variables
;;; (global) assumed global variable ;; (global) assumed global variable
;;; (lexical . <var>) lexical variables ;; (lexical . <var>) lexical variables
;;; (displaced-lexical) displaced lexicals ;; (displaced-lexical) displaced lexicals
;;; <level> ::= <nonnegative integer> ;; <level> ::= <nonnegative integer>
;;; <var> ::= variable returned by build-lexical-var ;; <var> ::= variable returned by build-lexical-var
;;; a macro is a user-defined syntactic-form. a core is a system-defined ;; a macro is a user-defined syntactic-form. a core is a system-defined
;;; syntactic form. begin, define, define-syntax, and eval-when are ;; syntactic form. begin, define, define-syntax, and eval-when are
;;; treated specially since they are sensitive to whether the form is ;; treated specially since they are sensitive to whether the form is
;;; at top-level and (except for eval-when) can denote valid internal ;; at top-level and (except for eval-when) can denote valid internal
;;; definitions. ;; definitions.
;;; a pattern variable is a variable introduced by syntax-case and can ;; a pattern variable is a variable introduced by syntax-case and can
;;; be referenced only within a syntax form. ;; be referenced only within a syntax form.
;;; any identifier for which no top-level syntax definition or local ;; any identifier for which no top-level syntax definition or local
;;; binding of any kind has been seen is assumed to be a global ;; binding of any kind has been seen is assumed to be a global
;;; variable. ;; variable.
;;; a lexical variable is a lambda- or letrec-bound variable. ;; a lexical variable is a lambda- or letrec-bound variable.
;;; a displaced-lexical identifier is a lexical identifier removed from ;; a displaced-lexical identifier is a lexical identifier removed from
;;; it's scope by the return of a syntax object containing the identifier. ;; it's scope by the return of a syntax object containing the identifier.
;;; a displaced lexical can also appear when a letrec-syntax-bound ;; a displaced lexical can also appear when a letrec-syntax-bound
;;; keyword is referenced on the rhs of one of the letrec-syntax clauses. ;; keyword is referenced on the rhs of one of the letrec-syntax clauses.
;;; a displaced lexical should never occur with properly written macros. ;; a displaced lexical should never occur with properly written macros.
(define-syntax make-binding (define-syntax make-binding
(syntax-rules (quote) (syntax-rules (quote)
@ -574,9 +574,9 @@
(extend-var-env (cdr labels) (cdr vars) (extend-var-env (cdr labels) (cdr vars)
(cons (cons (car labels) (make-binding 'lexical (car vars))) r))))) (cons (cons (car labels) (make-binding 'lexical (car vars))) r)))))
;;; we use a "macros only" environment in expansion of local macro ;; we use a "macros only" environment in expansion of local macro
;;; definitions so that their definitions can use local macros without ;; definitions so that their definitions can use local macros without
;;; attempting to use other lexical identifiers. ;; attempting to use other lexical identifiers.
(define macros-only-env (define macros-only-env
(lambda (r) (lambda (r)
(if (null? r) (if (null? r)
@ -603,10 +603,10 @@
(put-global-definition-hook sym type val))) (put-global-definition-hook sym type val)))
;;; Conceptually, identifiers are always syntax objects. Internally, ;; Conceptually, identifiers are always syntax objects. Internally,
;;; however, the wrap is sometimes maintained separately (a source of ;; however, the wrap is sometimes maintained separately (a source of
;;; efficiency and confusion), so that symbols are also considered ;; efficiency and confusion), so that symbols are also considered
;;; identifiers by id?. Externally, they are always wrapped. ;; identifiers by id?. Externally, they are always wrapped.
(define nonsymbol-id? (define nonsymbol-id?
(lambda (x) (lambda (x)
@ -636,12 +636,12 @@
(join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x)))) (join-marks (wrap-marks w) (wrap-marks (syntax-object-wrap x))))
(values x (wrap-marks w))))) (values x (wrap-marks w)))))
;;; syntax object wraps ;; syntax object wraps
;;; <wrap> ::= ((<mark> ...) . (<subst> ...)) ;; <wrap> ::= ((<mark> ...) . (<subst> ...))
;;; <subst> ::= <shift> | <subs> ;; <subst> ::= <shift> | <subs>
;;; <subs> ::= #(<old name> <label> (<mark> ...)) ;; <subs> ::= #(<old name> <label> (<mark> ...))
;;; <shift> ::= positive fixnum ;; <shift> ::= positive fixnum
(define make-wrap cons) (define make-wrap cons)
(define wrap-marks car) (define wrap-marks car)
@ -655,8 +655,8 @@
(syntax-rules () (syntax-rules ()
((_ old new marks) (vector old new marks)))) ((_ old new marks) (vector old new marks))))
;;; labels must be comparable with "eq?", have read-write invariance, ;; labels must be comparable with "eq?", have read-write invariance,
;;; and distinct from symbols. ;; and distinct from symbols.
(define gen-label (define gen-label
(lambda () (symbol->string (gensym "i")))) (lambda () (symbol->string (gensym "i"))))
@ -676,9 +676,9 @@
(syntax-rules () (syntax-rules ()
((_ w) (memq 'top (wrap-marks w))))) ((_ w) (memq 'top (wrap-marks w)))))
;;; Marks must be comparable with "eq?" and distinct from pairs and ;; Marks must be comparable with "eq?" and distinct from pairs and
;;; the symbol top. We do not use integers so that marks will remain ;; the symbol top. We do not use integers so that marks will remain
;;; unique even across file compiles. ;; unique even across file compiles.
(define-syntax the-anti-mark (identifier-syntax #f)) (define-syntax the-anti-mark (identifier-syntax #f))
@ -691,8 +691,8 @@
(syntax-rules () (syntax-rules ()
((_) (gensym "m")))) ((_) (gensym "m"))))
;;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for ;; make-empty-ribcage and extend-ribcage maintain list-based ribcages for
;;; internal definitions, in which the ribcages are built incrementally ;; internal definitions, in which the ribcages are built incrementally
(define-syntax make-empty-ribcage (define-syntax make-empty-ribcage
(syntax-rules () (syntax-rules ()
((_) (make-ribcage '() '() '())))) ((_) (make-ribcage '() '() '()))))
@ -709,7 +709,7 @@
(set-ribcage-labels! ribcage (set-ribcage-labels! ribcage
(cons label (ribcage-labels ribcage))))) (cons label (ribcage-labels ribcage)))))
;;; make-binding-wrap creates vector-based ribcages ;; make-binding-wrap creates vector-based ribcages
(define make-binding-wrap (define make-binding-wrap
(lambda (ids labels w) (lambda (ids labels w)
(if (null? ids) (if (null? ids)
@ -811,17 +811,17 @@
id)))))) id))))))
(else (syntax-violation 'id-var-name "invalid id" id))))) (else (syntax-violation 'id-var-name "invalid id" id)))))
;;; free-id=? must be passed fully wrapped ids since (free-id=? x y) ;; free-id=? must be passed fully wrapped ids since (free-id=? x y)
;;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not. ;; may be true even if (free-id=? (wrap x w) (wrap y w)) is not.
(define free-id=? (define free-id=?
(lambda (i j) (lambda (i j)
(and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator (and (eq? (id-sym-name i) (id-sym-name j)) ; accelerator
(eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap))))) (eq? (id-var-name i empty-wrap) (id-var-name j empty-wrap)))))
;;; bound-id=? may be passed unwrapped (or partially wrapped) ids as ;; bound-id=? may be passed unwrapped (or partially wrapped) ids as
;;; long as the missing portion of the wrap is common to both of the ids ;; long as the missing portion of the wrap is common to both of the ids
;;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w)) ;; since (bound-id=? x y) iff (bound-id=? (wrap x w) (wrap y w))
(define bound-id=? (define bound-id=?
(lambda (i j) (lambda (i j)
@ -832,10 +832,10 @@
(wrap-marks (syntax-object-wrap j)))) (wrap-marks (syntax-object-wrap j))))
(eq? i j)))) (eq? i j))))
;;; "valid-bound-ids?" returns #t if it receives a list of distinct ids. ;; "valid-bound-ids?" returns #t if it receives a list of distinct ids.
;;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids ;; valid-bound-ids? may be passed unwrapped (or partially wrapped) ids
;;; as long as the missing portion of the wrap is common to all of the ;; as long as the missing portion of the wrap is common to all of the
;;; ids. ;; ids.
(define valid-bound-ids? (define valid-bound-ids?
(lambda (ids) (lambda (ids)
@ -845,11 +845,11 @@
(all-ids? (cdr ids))))) (all-ids? (cdr ids)))))
(distinct-bound-ids? ids)))) (distinct-bound-ids? ids))))
;;; distinct-bound-ids? expects a list of ids and returns #t if there are ;; distinct-bound-ids? expects a list of ids and returns #t if there are
;;; no duplicates. It is quadratic on the length of the id list; long ;; no duplicates. It is quadratic on the length of the id list; long
;;; lists could be sorted to make it more efficient. distinct-bound-ids? ;; lists could be sorted to make it more efficient. distinct-bound-ids?
;;; may be passed unwrapped (or partially wrapped) ids as long as the ;; may be passed unwrapped (or partially wrapped) ids as long as the
;;; missing portion of the wrap is common to all of the ids. ;; missing portion of the wrap is common to all of the ids.
(define distinct-bound-ids? (define distinct-bound-ids?
(lambda (ids) (lambda (ids)
@ -864,7 +864,7 @@
(or (bound-id=? x (car list)) (or (bound-id=? x (car list))
(bound-id-member? x (cdr list)))))) (bound-id-member? x (cdr list))))))
;;; wrapping expressions and identifiers ;; wrapping expressions and identifiers
(define wrap (define wrap
(lambda (x w defmod) (lambda (x w defmod)
@ -882,7 +882,7 @@
(lambda (x w s defmod) (lambda (x w s defmod)
(wrap (decorate-source x s) w defmod))) (wrap (decorate-source x s) w defmod)))
;;; expanding ;; expanding
(define chi-sequence (define chi-sequence
(lambda (body r w s mod) (lambda (body r w s mod)
@ -933,41 +933,41 @@
e (wrap x w #f))))) e (wrap x w #f)))))
situations)))))) situations))))))
;;; syntax-type returns six values: type, value, e, w, s, and mod. The ;; syntax-type returns six values: type, value, e, w, s, and mod. The
;;; first two are described in the table below. ;; first two are described in the table below.
;;; ;;
;;; type value explanation ;; type value explanation
;;; ------------------------------------------------------------------- ;; -------------------------------------------------------------------
;;; core procedure core singleton ;; core procedure core singleton
;;; core-form procedure core form ;; core-form procedure core form
;;; module-ref procedure @ or @@ singleton ;; module-ref procedure @ or @@ singleton
;;; lexical name lexical variable reference ;; lexical name lexical variable reference
;;; global name global variable reference ;; global name global variable reference
;;; begin none begin keyword ;; begin none begin keyword
;;; define none define keyword ;; define none define keyword
;;; define-syntax none define-syntax keyword ;; define-syntax none define-syntax keyword
;;; local-syntax rec? letrec-syntax/let-syntax keyword ;; local-syntax rec? letrec-syntax/let-syntax keyword
;;; eval-when none eval-when keyword ;; eval-when none eval-when keyword
;;; syntax level pattern variable ;; syntax level pattern variable
;;; displaced-lexical none displaced lexical identifier ;; displaced-lexical none displaced lexical identifier
;;; lexical-call name call to lexical variable ;; lexical-call name call to lexical variable
;;; global-call name call to global variable ;; global-call name call to global variable
;;; call none any other call ;; call none any other call
;;; begin-form none begin expression ;; begin-form none begin expression
;;; define-form id variable definition ;; define-form id variable definition
;;; define-syntax-form id syntax definition ;; define-syntax-form id syntax definition
;;; local-syntax-form rec? syntax definition ;; local-syntax-form rec? syntax definition
;;; eval-when-form none eval-when form ;; eval-when-form none eval-when form
;;; constant none self-evaluating datum ;; constant none self-evaluating datum
;;; other none anything else ;; other none anything else
;;; ;;
;;; For define-form and define-syntax-form, e is the rhs expression. ;; For define-form and define-syntax-form, e is the rhs expression.
;;; For all others, e is the entire form. w is the wrap for e. ;; For all others, e is the entire form. w is the wrap for e.
;;; s is the source for the entire form. mod is the module for e. ;; s is the source for the entire form. mod is the module for e.
;;; ;;
;;; syntax-type expands macros and unwraps as necessary to get to ;; syntax-type expands macros and unwraps as necessary to get to
;;; one of the forms above. It also parses define and define-syntax ;; one of the forms above. It also parses define and define-syntax
;;; forms, although perhaps this should be done by the consumer. ;; forms, although perhaps this should be done by the consumer.
(define syntax-type (define syntax-type
(lambda (e r w s rib mod for-car?) (lambda (e r w s rib mod for-car?)
@ -1678,13 +1678,13 @@
(build-lambda-case s req opt rest kw inits vars (build-lambda-case s req opt rest kw inits vars
body else*)))))))))))) body else*))))))))))))
;;; data ;; data
;;; strips syntax-objects down to top-wrap ;; strips syntax-objects down to top-wrap
;;; ;;
;;; since only the head of a list is annotated by the reader, not each pair ;; since only the head of a list is annotated by the reader, not each pair
;;; in the spine, we also check for pairs whose cars are annotated in case ;; in the spine, we also check for pairs whose cars are annotated in case
;;; we've been passed the cdr of an annotated list ;; we've been passed the cdr of an annotated list
(define strip (define strip
(lambda (x w) (lambda (x w)
@ -1705,7 +1705,7 @@
(if (and-map* eq? old new) x (list->vector new))))) (if (and-map* eq? old new) x (list->vector new)))))
(else x)))))) (else x))))))
;;; lexical variables ;; lexical variables
(define gen-var (define gen-var
(lambda (id) (lambda (id)
@ -1728,7 +1728,7 @@
;; checking ;; checking
(else (cons vars ls)))))) (else (cons vars ls))))))
;;; core transformers ;; core transformers
(global-extend 'local-syntax 'letrec-syntax #t) (global-extend 'local-syntax 'letrec-syntax #t)
(global-extend 'local-syntax 'let-syntax #f) (global-extend 'local-syntax 'let-syntax #f)
@ -2361,15 +2361,15 @@
(list (chi #'val r empty-wrap mod)))) (list (chi #'val r empty-wrap mod))))
(syntax-violation 'syntax-case "invalid literals list" e)))))))) (syntax-violation 'syntax-case "invalid literals list" e))))))))
;;; The portable macroexpand seeds chi-top's mode m with 'e (for ;; The portable macroexpand seeds chi-top's mode m with 'e (for
;;; evaluating) and esew (which stands for "eval syntax expanders ;; evaluating) and esew (which stands for "eval syntax expanders
;;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e ;; when") with '(eval). In Chez Scheme, m is set to 'c instead of e
;;; if we are compiling a file, and esew is set to ;; if we are compiling a file, and esew is set to
;;; (eval-syntactic-expanders-when), which defaults to the list ;; (eval-syntactic-expanders-when), which defaults to the list
;;; '(compile load eval). This means that, by default, top-level ;; '(compile load eval). This means that, by default, top-level
;;; syntactic definitions are evaluated immediately after they are ;; syntactic definitions are evaluated immediately after they are
;;; expanded, and the expanded definitions are also residualized into ;; expanded, and the expanded definitions are also residualized into
;;; the object file if we are compiling a file. ;; the object file if we are compiling a file.
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(chi-top x null-env top-wrap m esew (chi-top x null-env top-wrap m esew
@ -2426,28 +2426,28 @@
(if who (cons who tail) tail)) (if who (cons who tail) tail))
#f))) #f)))
;;; $sc-dispatch expects an expression and a pattern. If the expression ;; $sc-dispatch expects an expression and a pattern. If the expression
;;; matches the pattern a list of the matching expressions for each ;; matches the pattern a list of the matching expressions for each
;;; "any" is returned. Otherwise, #f is returned. (This use of #f will ;; "any" is returned. Otherwise, #f is returned. (This use of #f will
;;; not work on r4rs implementations that violate the ieee requirement ;; not work on r4rs implementations that violate the ieee requirement
;;; that #f and () be distinct.) ;; that #f and () be distinct.)
;;; The expression is matched with the pattern as follows: ;; The expression is matched with the pattern as follows:
;;; pattern: matches: ;; pattern: matches:
;;; () empty list ;; () empty list
;;; any anything ;; any anything
;;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2) ;; (<pattern>1 . <pattern>2) (<pattern>1 . <pattern>2)
;;; each-any (any*) ;; each-any (any*)
;;; #(free-id <key>) <key> with free-identifier=? ;; #(free-id <key>) <key> with free-identifier=?
;;; #(each <pattern>) (<pattern>*) ;; #(each <pattern>) (<pattern>*)
;;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3) ;; #(each+ p1 (p2_1 ... p2_n) p3) (p1* (p2_n ... p2_1) . p3)
;;; #(vector <pattern>) (list->vector <pattern>) ;; #(vector <pattern>) (list->vector <pattern>)
;;; #(atom <object>) <object> with "equal?" ;; #(atom <object>) <object> with "equal?"
;;; Vector cops out to pair under assumption that vectors are rare. If ;; Vector cops out to pair under assumption that vectors are rare. If
;;; not, should convert to: ;; not, should convert to:
;;; #(vector <pattern>*) #(<pattern>*) ;; #(vector <pattern>*) #(<pattern>*)
(let () (let ()
@ -2587,10 +2587,8 @@
((syntax-object? e) ((syntax-object? e)
(match* (syntax-object-expression e) (match* (syntax-object-expression e)
p (syntax-object-wrap e) '() (syntax-object-module e))) p (syntax-object-wrap e) '() (syntax-object-module e)))
(else (match* e p empty-wrap '() #f))))) (else (match* e p empty-wrap '() #f))))))))
))
)
(define-syntax with-syntax (define-syntax with-syntax
(lambda (x) (lambda (x)