mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

unify variant types and records; also make-foo instead of <foo>

Browse source 
* module/system/base/syntax.scm (define-record): Rework to separate the
  type and its constructor. Now (define-record (<foo> bar)) will create
  `make-foo' as the constructor, not `<foo>'. Also the constructor now
  takes either keyword or positional arguments, so that it can be used as
  the implementation of variant types as well.
  (|): Map directly to define-record instead of rolling our own thing.

* module/language/scheme/translate.scm:
* module/system/base/language.scm:
* module/system/il/compile.scm:
* module/system/il/ghil.scm:
* module/system/il/glil.scm:
* module/system/repl/common.scm:
* module/system/vm/assemble.scm:
* module/system/vm/debug.scm: Change instances of record creation to use
  the make-foo procedures instead of <foo>. Adjust module exports as
  necessary.
This commit is contained in:
Andy Wingo 2008-05-03 18:32:46 +02:00
parent 1aa0dd2b45
commit 849cefacf1
9 changed files with 151 additions and 151 deletions
Download patch file Download diff file Expand all files Collapse all files

44
module/language/scheme/translate.scm
View file

@ -52,7 +52,7 @@
(call-with-ghil-environment (make-ghil-mod e) '()
(lambda (env vars)
(<ghil-lambda> env #f vars #f (trans env #f x))))))
(make-ghil-lambda env #f vars #f (trans env #f x))))))
;;;
@ -139,9 +139,9 @@
((symbol? x)
(let ((y (symbol-expand x)))
(if (symbol? y)
(<ghil-ref> e l (ghil-lookup e y))
(make-ghil-ref e l (ghil-lookup e y))
(trans e l y))))
(else (<ghil-quote> e l x))))
(else (make-ghil-quote e l x))))
(define (symbol-expand x)
(let loop ((s (symbol->string x)))
@ -155,7 +155,7 @@
(define (trans:x x) (trans e l x))
(define (trans:pair x) (trans-pair e l (car x) (cdr x)))
(define (trans:body body) (trans-body e l body))
(define (make:void) (<ghil-void> e l))
(define (make:void) (make-ghil-void e l))
(define (bad-syntax)
(syntax-error l (format #f "bad ~A" head) (cons head tail)))
(case head
@ -168,26 +168,26 @@
;; (quote OBJ)
((quote)
(match tail
((obj) (<ghil-quote> e l obj))
((obj) (make-ghil-quote e l obj))
(else (bad-syntax))))
;; (quasiquote OBJ)
((quasiquote)
(match tail
((obj) (<ghil-quasiquote> e l (trans-quasiquote e l obj)))
((obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))
(else (bad-syntax))))
((define define-private)
(match tail
;; (define NAME VAL)
(((? symbol? name) val)
(<ghil-define> e l (ghil-lookup e name) (trans:x val)))
(make-ghil-define e l (ghil-lookup e name) (trans:x val)))
;; (define (NAME FORMALS...) BODY...)
((((? symbol? name) . formals) . body)
;; -> (define NAME (lambda FORMALS BODY...))
(let ((val (trans:x `(lambda ,formals ,@body))))
(<ghil-define> e l (ghil-lookup e name) val)))
(make-ghil-define e l (ghil-lookup e name) val)))
(else (bad-syntax))))
@ -203,7 +203,7 @@
(match tail
;; (set! NAME VAL)
(((? symbol? name) val)
(<ghil-set> e l (ghil-lookup e name) (trans:x val)))
(make-ghil-set e l (ghil-lookup e name) (trans:x val)))
;; (set! (NAME ARGS...) VAL)
((((? symbol? name) . args) val)
@ -216,22 +216,22 @@
((if)
(match tail
((test then)
(<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
(make-ghil-if e l (trans:x test) (trans:x then) (make:void)))
((test then else)
(<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
(make-ghil-if e l (trans:x test) (trans:x then) (trans:x else)))
(else (bad-syntax))))
;; (and EXPS...)
((and)
(<ghil-and> e l (map trans:x tail)))
(make-ghil-and e l (map trans:x tail)))
;; (or EXPS...)
((or)
(<ghil-or> e l (map trans:x tail)))
(make-ghil-or e l (map trans:x tail)))
;; (begin EXPS...)
((begin)
(<ghil-begin> e l (map trans:x tail)))
(make-ghil-begin e l (map trans:x tail)))
((let)
(match tail
@ -243,14 +243,14 @@
;; (let () BODY...)
((() body ...)
;; NOTE: This differs from `begin'
(<ghil-begin> e l (list (trans:body body))))
(make-ghil-begin e l (list (trans:body body))))
;; (let ((SYM VAL) ...) BODY...)
(((((? symbol? sym) val) ...) body ...)
(let ((vals (map trans:x val)))
(call-with-ghil-bindings e sym
(lambda (vars)
(<ghil-bind> e l vars vals (trans:body body))))))
(make-ghil-bind e l vars vals (trans:body body))))))
(else (bad-syntax))))
@ -270,7 +270,7 @@
(call-with-ghil-bindings e sym
(lambda (vars)
(let ((vals (map trans:x val)))
(<ghil-bind> e l vars vals (trans:body body))))))
(make-ghil-bind e l vars vals (trans:body body))))))
(else (bad-syntax))))
;; (cond (CLAUSE BODY...) ...)
@ -321,7 +321,7 @@
(receive (syms rest) (parse-formals formals)
(call-with-ghil-environment e syms
(lambda (env vars)
(<ghil-lambda> env l vars rest (trans-body env l body))))))
(make-ghil-lambda env l vars rest (trans-body env l body))))))
(else (bad-syntax))))
((eval-case)
@ -339,11 +339,11 @@
(else
(if (memq head %scheme-primitives)
(<ghil-inline> e l head (map trans:x tail))
(make-ghil-inline e l head (map trans:x tail))
(if (memq head %forbidden-primitives)
(syntax-error l (format #f "`~a' is forbidden" head)
(cons head tail))
(<ghil-call> e l (trans:x head) (map trans:x tail)))))))
(make-ghil-call e l (trans:x head) (map trans:x tail)))))))
(define (trans-quasiquote e l x)
(cond ((not (pair? x)) x)
@ -352,8 +352,8 @@
(match (cdr x)
((obj)
(if (eq? (car x) 'unquote)
(<ghil-unquote> e l (trans e l obj))
(<ghil-unquote-splicing> e l (trans e l obj))))
(make-ghil-unquote e l (trans e l obj))
(make-ghil-unquote-splicing e l (trans e l obj))))
(else (syntax-error l (format #f "bad ~A" (car x)) x)))))
(else (cons (trans-quasiquote e l (car x))
(trans-quasiquote e l (cdr x))))))