mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

expanded type constructors in psyntax

Browse source 
* module/ice-9/psyntax.scm (define-expansion-constructors): Define
  constructors for expanded types.

* module/ice-9/psyntax-pp.scm: Regenerated.
This commit is contained in:
Andy Wingo 2010-05-19 23:37:27 +02:00
parent f7b61b39d3
commit 3d10018e7f
2 changed files with 9113 additions and 8067 deletions
Download patch file Download diff file Expand all files Collapse all files

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

File diff suppressed because it is too large Load diff

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

@ -224,6 +224,24 @@
(apply f (cons x xr)) (apply f (cons x xr))
(and (apply f (cons x xr)) (andmap first rest))))))))) (and (apply f (cons x xr)) (andmap first rest)))))))))
(define-syntax define-expansion-constructors
(lambda (x)
(syntax-case x ()
((_)
(let lp ((n 0) (out '()))
(if (< n (vector-length %expanded-vtables))
(lp (1+ n)
(let* ((vtable (vector-ref %expanded-vtables n))
(stem (struct-ref vtable (+ vtable-offset-user 0)))
(fields (struct-ref vtable (+ vtable-offset-user 2)))
(sfields (map (lambda (f) (datum->syntax x f)) fields))
(ctor (datum->syntax x (symbol-append 'make- stem))))
(cons #`(define (#,ctor #,@sfields)
(make-struct (vector-ref %expanded-vtables #,n) 0
#,@sfields))
out)))
#`(begin #,@(reverse out))))))))
(define-syntax define-structure (define-syntax define-structure
(lambda (x) (lambda (x)
(define construct-name (define construct-name
@ -278,6 +296,8 @@
(let () (let ()
(define *mode* (make-fluid)) (define *mode* (make-fluid))
(define-expansion-constructors)
;;; hooks to nonportable run-time helpers ;;; hooks to nonportable run-time helpers
(begin (begin
(define fx+ +) (define fx+ +)