+++ /dev/null
-;;; Guile Scheme specification
-
-;; Copyright (C) 2001 Free Software Foundation, Inc.
-
-;; This program is free software; you can redistribute it and/or modify
-;; it under the terms of the GNU General Public License as published by
-;; the Free Software Foundation; either version 2, or (at your option)
-;; any later version.
-;;
-;; This program is distributed in the hope that it will be useful,
-;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;; GNU General Public License for more details.
-;;
-;; You should have received a copy of the GNU General Public License
-;; along with this program; see the file COPYING. If not, write to
-;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
-;; Boston, MA 02111-1307, USA.
-
-;;; Code:
-
-(define-module (language gscheme spec)
- :use-module (system base language)
- :use-module (system il ghil)
- :use-module (ice-9 match)
- :use-module (ice-9 and-let-star)
- :export (gscheme))
-
-\f
-;;;
-;;; Translator
-;;;
-
-(define (translate x) (if (pair? x) (translate-pair x) x))
-
-(define (translate-pair x)
- (let ((head (car x)) (rest (cdr x)))
- (case head
- ((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 ...)
- `(@letrec ((,f (@lambda ,s ,@(map translate body))))
- (,f ,@(map translate v))))
- (else
- (cons* (symbol-append '@ head)
- (map (lambda (b) (cons (car b) (map translate (cdr b))))
- (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 ...)
- (define (translate-update s x)
- (if (pair? x) (translate (car x)) s))
- `(@letrec ((_loop (@lambda
- ,sym
- (@if ,(translate test)
- (@begin ,@(map translate result))
- (@begin ,@(map translate body)
- (_loop ,@(map translate-update
- sym update)))))))
- (_loop ,@(map translate init))))))
-
- ((eval-case)
- `(@eval-case
- ,@(let loop ((x rest))
- (match x
- (() '(()))
- ((('else . body)) `((@else ,@(map translate body))))
- (((keys . body) . rest)
- `((,keys ,@(map translate body)) ,@(loop rest)))
- (else (error "bad eval-case" x))))))
-
- (else
- (let ((e (expand x)))
- (if (eq? e x)
- (let ((prim (and (symbol? head) (symbol-append '@ head))))
- (if (and prim (ghil-primitive? prim))
- (cons prim (map translate rest))
- (cons (translate head) (map translate rest))))
- (translate e)))))))
-
-(define (expand x)
- (if (and (symbol? (car x))
- (module-defined? (current-module) (car x)))
- (let ((v (module-ref (current-module) (car x))))
- (if (defmacro? v)
- (apply (defmacro-transformer v) (cdr x))
- x))
- x))
-
-\f
-;;;
-;;; Language definition
-;;;
-
-(define-language gscheme
- :title "Guile Scheme"
- :version "0.4"
- :reader read
- :translator translate
- :printer write
- )
--- /dev/null
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 2, or (at your option)
+;; any later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with this program; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+;;; Code:
+
+(define-module (language scheme translate)
+ :use-module (system base language)
+ :use-module (system il ghil)
+ :use-module (ice-9 match)
+ :use-module (ice-9 receive)
+ :export (translate))
+
+(define (translate x e)
+ (call-with-ghil-environment (make-ghil-mod e) '()
+ (lambda (env vars)
+ (make-<ghil-lambda> env #f vars 0 (trans env #f x)))))
+
+\f
+;;;
+;;; Translator
+;;;
+
+(define (trans e l x)
+ (cond ((pair? x)
+ (let ((y (macroexpand x)))
+ (if (eq? x y)
+ (trans-pair e (or (location x) l) (car x) (cdr x))
+ (trans e l y))))
+ ((symbol? x) (make-<ghil-ref> e l (ghil-lookup e x)))
+ (else (make-<ghil-quote> e l x))))
+
+(define (trans-pair e l head tail)
+ (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) (make-<ghil-void> e l))
+ (define (bad-syntax)
+ (syntax-error l (format #f "bad ~A" head) (cons head tail)))
+ (case head
+ ;; (void)
+ ((void)
+ (match tail
+ (() (make:void))
+ (else (bad-syntax))))
+
+ ;; (quote OBJ)
+ ((quote)
+ (match tail
+ ((obj) (make-<ghil-quote> e l obj))
+ (else (bad-syntax))))
+
+ ;; (quasiquote OBJ)
+ ((quasiquote)
+ (match tail
+ ((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)
+ (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))))
+ (make-<ghil-define> e l (ghil-lookup e name) val)))
+
+ (else (bad-syntax))))
+
+ ((set!)
+ (match tail
+ ;; (set! NAME VAL)
+ (((? symbol? name) val)
+ (make-<ghil-set> e l (ghil-lookup e name) (trans:x val)))
+
+ ;; (set! (NAME ARGS...) VAL)
+ ((((? symbol? name) . args) val)
+ ;; -> ((setter NAME) ARGS... VAL)
+ (trans:pair `((setter ,name) (,@args ,val))))
+
+ (else (bad-syntax))))
+
+ ;; (if TEST THEN [ELSE])
+ ((if)
+ (match tail
+ ((test then)
+ (make-<ghil-if> e l (trans:x test) (trans:x then) (make:void)))
+ ((test then else)
+ (make-<ghil-if> e l (trans:x test) (trans:x then) (trans:x else)))
+ (else (bad-syntax))))
+
+ ;; (and EXPS...)
+ ((and)
+ (make-<ghil-and> e l (map trans:x tail)))
+
+ ;; (or EXPS...)
+ ((or)
+ (make-<ghil-or> e l (map trans:x tail)))
+
+ ;; (begin EXPS...)
+ ((begin)
+ (make-<ghil-begin> e l (map trans:x tail)))
+
+ ((let)
+ (match tail
+ ;; (let NAME ((SYM VAL) ...) BODY...)
+ (((? symbol? name) (((? symbol? sym) val) ...) body ...)
+ ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
+ (trans:pair `(letrec ((,name (lambda ,sym ,@body))) (,name ,@val))))
+
+ ;; (let () BODY...)
+ ((() body ...)
+ ;; NOTE: This differs from `begin'
+ (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)
+ (make-<ghil-bind> e l vars vals (trans:body body))))))
+
+ (else (bad-syntax))))
+
+ ;; (let* ((SYM VAL) ...) BODY...)
+ ((let*)
+ (match tail
+ (((def ...) body ...)
+ (if (null? def)
+ (trans:pair `(let () ,@body))
+ (trans:pair `(let (,(car def)) (let* ,(cdr def) ,@body)))))
+ (else (bad-syntax))))
+
+ ;; (letrec ((SYM VAL) ...) BODY...)
+ ((letrec)
+ (match tail
+ (((((? symbol? sym) val) ...) body ...)
+ (call-with-ghil-bindings e sym
+ (lambda (vars)
+ (let ((vals (map trans:x val)))
+ (make-<ghil-bind> e l vars vals (trans:body body))))))
+ (else (bad-syntax))))
+
+ ;; (cond (CLAUSE BODY...) ...)
+ ((cond)
+ (match tail
+ (() (make:void))
+ ((('else . body)) (trans:body body))
+ (((test) . rest) (trans:pair `(or ,test (cond ,@rest))))
+ (((test '=> proc) . rest)
+ (trans:pair `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
+ (((test . body) . rest)
+ (trans:pair `(if ,test (begin ,@body) (cond ,@rest))))
+ (else (bad-syntax))))
+
+ ;; (case EXP ((KEY...) BODY...) ...)
+ ((case)
+ (match tail
+ ((exp . clauses)
+ (trans:pair
+ `(let ((_t ,exp))
+ ,(let loop ((ls clauses))
+ (cond ((null? ls) '(void))
+ ((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
+ (else `(if (memv _t ',(caar ls))
+ (begin ,@(cdar ls))
+ ,(loop (cdr ls)))))))))
+ (else (bad-syntax))))
+
+ ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
+ ((do)
+ (let ()
+ (define (next s x) (if (pair? x) (car x) s))
+ (match tail
+ ((((sym init . update) ...) (test . result) body ...)
+ (trans:pair
+ `(letrec ((_l (lambda ,sym
+ (if ,test
+ (let () (void) ,@result)
+ (let () (void) ,@body
+ (_l ,@(map next sym update)))))))
+ (_l ,@init))))
+ (else (bad-syntax)))))
+
+ ;; (lambda FORMALS BODY...)
+ ((lambda)
+ (match tail
+ ((formals body ...)
+ (receive (syms rest) (parse-formals formals)
+ (call-with-ghil-environment e syms
+ (lambda (env vars)
+ (make-<ghil-lambda> env l vars rest (trans-body env l body))))))
+ (else (bad-syntax))))
+
+ ((eval-case)
+ (let loop ((x tail))
+ (match x
+ (() (make:void))
+ ((('else . body)) (trans:pair `(begin ,@body)))
+ (((((? symbol? key) ...) body ...) rest ...)
+ (if (memq 'compile key)
+ (primitive-eval `(begin ,@(copy-tree body))))
+ (if (memq 'load-toplevel key)
+ (trans:pair `(begin ,@body))
+ (loop rest)))
+ (else (bad-syntax)))))
+
+ (else
+ (make-<ghil-call> e l (trans:x head) (map trans:x tail)))))
+
+(define (trans-quasiquote e l x)
+ (cond ((not (pair? x)) x)
+ ((memq (car x) '(unquote unquote-splicing))
+ (let ((l (location x)))
+ (match (cdr x)
+ ((obj)
+ (if (eq? (car x) 'unquote)
+ (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))))))
+
+(define (trans-body e l body)
+ (define (define->binding df)
+ (match (cdr df)
+ (((? symbol? name) val) (list name val))
+ ((((? symbol? name) . formals) . body)
+ (list name `(lambda ,formals ,@body)))
+ (else (syntax-error (location df) "bad define" df))))
+ ;; main
+ (let loop ((ls body) (ds '()))
+ (cond ((null? ls) (syntax-error l "bad body" body))
+ ((and (pair? (car ls)) (eq? (caar ls) 'define))
+ (loop (cdr ls) (cons (car ls) ds)))
+ (else
+ (if (null? ds)
+ (trans-pair e l 'begin ls)
+ (trans-pair e l 'letrec (cons (map define->binding ds) ls)))))))
+
+(define (parse-formals formals)
+ (cond
+ ;; (lambda x ...)
+ ((symbol? formals) (values (list formals) #t))
+ ;; (lambda (x y z) ...)
+ ((list? formals) (values formals #f))
+ ;; (lambda (x y . z) ...)
+ ((pair? formals)
+ (let loop ((l formals) (v '()))
+ (if (pair? l)
+ (loop (cdr l) (cons (car l) v))
+ (values (reverse! (cons l v)) #t))))
+ (else (syntax-error (location formals) "bad formals" formals))))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ (cons (assq-ref props 'line) (assq-ref props 'column))))))
HCoop / bpt / guile.git / commitdiff