summaryrefslogtreecommitdiff
path: root/module/language/gscheme/spec.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/language/gscheme/spec.scm')
-rw-r--r--module/language/gscheme/spec.scm90
1 files changed, 90 insertions, 0 deletions
diff --git a/module/language/gscheme/spec.scm b/module/language/gscheme/spec.scm
new file mode 100644
index 000000000..c2a9ed7b6
--- /dev/null
+++ b/module/language/gscheme/spec.scm
@@ -0,0 +1,90 @@
+;;; Guile Scheme specification
+
+;; Copyright (C) 2001 Free Software Foundation, Inc.
+
+;; Guile VM 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.
+;;
+;; Guile VM 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 Guile VM; see the file COPYING. If not, write to
+;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
+
+(define-module (language gscheme spec)
+ :use-module (system base language)
+ :use-module (ice-9 match)
+ :export (gscheme))
+
+
+;;;
+;;; Macro expander
+;;;
+
+(define (expand x)
+ (if (pair? x)
+ (let* ((s (car x))
+ (m (current-module))
+ (v (and (symbol? s) (module-defined? m s) (module-ref m s))))
+ (if (defmacro? v)
+ (expand (apply (defmacro-transformer v) (cdr x)))
+ (cons (expand (car x)) (expand (cdr x)))))
+ x))
+
+
+;;;
+;;; Translator
+;;;
+
+(define *primitive-procedure-list*
+ '(void car cdr cons + - < >))
+
+(define (translate x) (if (pair? x) (translate-pair x) x))
+
+(define (translate-pair x)
+ (let ((name (car x)) (args (cdr x)))
+ (case name
+ ((quote) (cons '@quote args))
+ ((set! if and or begin)
+ (cons (symbol-append '@ name) (map translate args)))
+ ((define)
+ (if (pair? (car args))
+ `(@define ,(caar args)
+ (@lambda ,(cdar args) ,@(map translate (cdr args))))
+ `(@define ,(car args) ,@(map translate (cdr args)))))
+ ((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 '@ name)
+ (map (lambda (b) (cons (car b) (map translate (cdr b))))
+ (car args))
+ (map translate (cdr args))))))
+ ((lambda)
+ (cons* '@lambda (car args) (map translate (cdr args))))
+ (else
+ (if (memq name *primitive-procedure-list*)
+ (cons (symbol-append '@ name) (map translate args))
+ (cons (translate name) (map translate args)))))))
+
+
+;;;
+;;; Language definition
+;;;
+
+(define-language gscheme
+ :title "Guile Scheme"
+ :version "0.3"
+ :reader read
+ :expander expand
+ :translator translate
+ :printer write
+ )