mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-08 21:52:28 +02:00
Code Activity

*** empty log message ***

Browse source
This commit is contained in:
Keisuke Nishida 2001-04-07 11:54:36 +00:00
parent 731f329c29
commit c0a25eccef
8 changed files with 97 additions and 38 deletions
Download patch file Download diff file Expand all files Collapse all files

57
module/language/gscheme/spec.scm
View file

@ -22,7 +22,6 @@
(define-module (language gscheme spec)
:use-module (system base language)
:use-module (system il ghil)
:use-module (language r5rs expand)
:use-module (ice-9 match)
:use-module (ice-9 and-let-star)
:export (gscheme))
@ -32,7 +31,8 @@
;;; Macro expander
;;;
(define expand-syntax expand)
(define (expand x)
(expand-macro x (current-module)))
(define (expand-macro x m)
(if (pair? x)
@ -43,9 +43,6 @@
(cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
x))
(define (expand x)
(expand-syntax (expand-macro x (current-module))))
;;;
;;; Translator
@ -56,9 +53,18 @@
(define (translate-pair x)
(let ((head (car x)) (rest (cdr x)))
(case head
((quote) (cons '@quote rest))
((define set! if and or begin)
((quote) `(@quote ,@rest))
((set! if and or begin)
(cons (symbol-append '@ head) (map translate rest)))
((define)
(match rest
((((? symbol? name) . args) . body)
`(@define ,name (@lambda ,args ,@(map translate body))))
(((? symbol? name) val)
`(@define ,name ,(translate val)))
(else (error "Syntax error:" x))))
((lambda)
`(@lambda ,(car rest) ,@(map translate (cdr rest))))
((let let* letrec)
(match x
(('let (? symbol? f) ((s v) ...) body ...)
@ -69,8 +75,41 @@
(map (lambda (b) (cons (car b) (map translate (cdr b))))
(car rest))
(map translate (cdr rest))))))
((lambda)
(cons* '@lambda (car rest) (map translate (cdr rest))))
((cond)
(let loop ((x rest))
(match x
(() '(@void))
((('else . body)) `(@begin ,@(map translate body)))
(((test) . rest) `(@or ,(translate test) ,(loop rest)))
(((test '=> proc) . rest)
`(@let ((_t ,(translate test)))
(@if _t (,(translate proc) _t) ,(loop rest))))
(((test . body) . rest)
`(@if ,(translate test)
(@begin ,@(map translate body))
,(loop rest)))
(else (error "bad cond" x)))))
((case)
`(@let ((_t ,(translate (car rest))))
,(let loop ((x (cdr rest)))
(match x
(() '(@void))
((('else . body)) `(@begin ,@(map translate body)))
((((keys ...) . body) . rest)
`(@if (@memv _t (@quote ,keys))
(@begin ,@(map translate body))
,(loop rest)))
(else (error "bad cond" x))))))
((do)
(match rest
((((sym init update) ...) (test . result) body ...)
`(@letrec ((_loop (@lambda
,sym
(@if ,(translate test)
(@begin ,@(map translate result))
(@begin ,@(map translate body)
(_loop ,@(map translate update)))))))
(_loop ,@(map translate init))))))
(else
(let ((prim (and (symbol? head) (symbol-append '@ head))))
(if (and prim (ghil-primitive? prim))