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

psyntax uses define-syntax-rule

Browse source 
* module/ice-9/psyntax.scm: Use define-syntax-rule.

* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2011-09-02 11:34:00 +02:00
parent dea14eb99b
commit 1bbe0a631c
2 changed files with 7844 additions and 7857 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -272,9 +272,8 @@
(lambda (x mod) (lambda (x mod)
(primitive-eval x))) (primitive-eval x)))
(define-syntax gensym-hook (define-syntax-rule (gensym-hook)
(syntax-rules () (gensym))
((_) (gensym))))
(define put-global-definition-hook (define put-global-definition-hook
(lambda (symbol type val) (lambda (symbol type val)
@ -449,9 +448,8 @@
;; FIXME: use a faster gensym ;; FIXME: use a faster gensym
(define-syntax build-lexical-var (define-syntax-rule (build-lexical-var src id)
(syntax-rules () (gensym (string-append (symbol->string id) " ")))
((_ src id) (gensym (string-append (symbol->string id) " ")))))
(define-structure (syntax-object expression wrap module)) (define-structure (syntax-object expression wrap module))
@ -468,11 +466,9 @@
#f))) #f)))
(else #f)))) (else #f))))
(define-syntax arg-check (define-syntax-rule (arg-check pred? e who)
(syntax-rules () (let ((x e))
((_ pred? e who) (if (not (pred? x)) (syntax-violation who "invalid argument" x))))
(let ((x e))
(if (not (pred? x)) (syntax-violation who "invalid argument" x))))))
;; compile-time environments ;; compile-time environments
@ -535,12 +531,10 @@
((_ type value) (cons type value)) ((_ type value) (cons type value))
((_ 'type) '(type)) ((_ 'type) '(type))
((_ type) (cons type '())))) ((_ type) (cons type '()))))
(define-syntax binding-type (define-syntax-rule (binding-type x)
(syntax-rules () (car x))
((_ x) (car x)))) (define-syntax-rule (binding-value x)
(define-syntax binding-value (cdr x))
(syntax-rules ()
((_ x) (cdr x))))
(define-syntax null-env (identifier-syntax '())) (define-syntax null-env (identifier-syntax '()))
@ -605,13 +599,11 @@
((syntax-object? x) (symbol? (syntax-object-expression x))) ((syntax-object? x) (symbol? (syntax-object-expression x)))
(else #f)))) (else #f))))
(define-syntax id-sym-name (define-syntax-rule (id-sym-name e)
(syntax-rules () (let ((x e))
((_ e) (if (syntax-object? x)
(let ((x e)) (syntax-object-expression x)
(if (syntax-object? x) x)))
(syntax-object-expression x)
x)))))
(define id-sym-name&marks (define id-sym-name&marks
(lambda (x w) (lambda (x w)
@ -633,12 +625,11 @@
(define-syntax wrap-subst (identifier-syntax cdr)) (define-syntax wrap-subst (identifier-syntax cdr))
(define-syntax subst-rename? (identifier-syntax vector?)) (define-syntax subst-rename? (identifier-syntax vector?))
(define-syntax rename-old (syntax-rules () ((_ x) (vector-ref x 0)))) (define-syntax-rule (rename-old x) (vector-ref x 0))
(define-syntax rename-new (syntax-rules () ((_ x) (vector-ref x 1)))) (define-syntax-rule (rename-new x) (vector-ref x 1))
(define-syntax rename-marks (syntax-rules () ((_ x) (vector-ref x 2)))) (define-syntax-rule (rename-marks x) (vector-ref x 2))
(define-syntax make-rename (define-syntax-rule (make-rename old new marks)
(syntax-rules () (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.
@ -657,9 +648,8 @@
(define-syntax top-wrap (identifier-syntax '((top)))) (define-syntax top-wrap (identifier-syntax '((top))))
(define-syntax top-marked? (define-syntax-rule (top-marked? w)
(syntax-rules () (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
@ -672,15 +662,13 @@
(make-wrap (cons the-anti-mark (wrap-marks w)) (make-wrap (cons the-anti-mark (wrap-marks w))
(cons 'shift (wrap-subst w))))) (cons 'shift (wrap-subst w)))))
(define-syntax new-mark (define-syntax-rule (new-mark)
(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-rule (make-empty-ribcage)
(syntax-rules () (make-ribcage '() '() '()))
((_) (make-ribcage '() '() '()))))
(define extend-ribcage! (define extend-ribcage!
;; must receive ids with complete wraps ;; must receive ids with complete wraps
@ -749,10 +737,9 @@
(define id-var-name (define id-var-name
(lambda (id w) (lambda (id w)
(define-syntax first (define-syntax-rule (first e)
(syntax-rules () ;; Rely on Guile's multiple-values truncation.
;; Rely on Guile's multiple-values truncation. e)
((_ e) e)))
(define search (define search
(lambda (sym subst marks) (lambda (sym subst marks)
(if (null? subst) (if (null? subst)