module/language/gscheme/spec.scm

   1 ;;; Guile Scheme specification
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (language gscheme spec)
  23   :use-module (system base language)
  24   :use-module (system il ghil)
  25   :use-module (ice-9 match)
  26   :use-module (ice-9 and-let-star)
  27   :export (gscheme))
  28
  29 \f
  30 ;;;
  31 ;;; Macro expander
  32 ;;;
  33
  34 (define (expand x)
  35   (expand-macro x (current-module)))
  36
  37 (define (expand-macro x m)
  38   (if (pair? x)
  39       (let* ((s (car x))
  40              (v (and (symbol? s) (module-defined? m s) (module-ref m s))))
  41         (if (defmacro? v)
  42             (expand-macro (apply (defmacro-transformer v) (cdr x)) m)
  43             (cons (expand-macro (car x) m) (expand-macro (cdr x) m))))
  44       x))
  45
  46 \f
  47 ;;;
  48 ;;; Translator
  49 ;;;
  50
  51 (define (translate x) (if (pair? x) (translate-pair x) x))
  52
  53 (define (translate-pair x)
  54   (let ((head (car x)) (rest (cdr x)))
  55     (case head
  56       ((quote) `(@quote ,@rest))
  57       ((set! if and or begin)
  58        (cons (symbol-append '@ head) (map translate rest)))
  59       ((define)
  60        (match rest
  61          ((((? symbol? name) . args) . body)
  62           `(@define ,name (@lambda ,args ,@(map translate body))))
  63          (((? symbol? name) val)
  64           `(@define ,name ,(translate val)))
  65          (else (error "Syntax error:" x))))
  66       ((lambda)
  67        `(@lambda ,(car rest) ,@(map translate (cdr rest))))
  68       ((let let* letrec)
  69        (match x
  70          (('let (? symbol? f) ((s v) ...) body ...)
  71           `(@letrec ((,f (@lambda ,s ,@(map translate body))))
  72                     (,f ,@(map translate v))))
  73          (else
  74           (cons* (symbol-append '@ head)
  75                  (map (lambda (b) (cons (car b) (map translate (cdr b))))
  76                       (car rest))
  77                  (map translate (cdr rest))))))
  78       ((cond)
  79        (let loop ((x rest))
  80          (match x
  81            (() '(@void))
  82            ((('else . body)) `(@begin ,@(map translate body)))
  83            (((test) . rest) `(@or ,(translate test) ,(loop rest)))
  84            (((test '=> proc) . rest)
  85             `(@let ((_t ,(translate test)))
  86                    (@if _t (,(translate proc) _t) ,(loop rest))))
  87            (((test . body) . rest)
  88             `(@if ,(translate test)
  89                   (@begin ,@(map translate body))
  90                   ,(loop rest)))
  91            (else (error "bad cond" x)))))
  92       ((case)
  93        `(@let ((_t ,(translate (car rest))))
  94               ,(let loop ((x (cdr rest)))
  95                  (match x
  96                    (() '(@void))
  97                    ((('else . body)) `(@begin ,@(map translate body)))
  98                    ((((keys ...) . body) . rest)
  99                     `(@if (@memv _t (@quote ,keys))
 100                           (@begin ,@(map translate body))
 101                           ,(loop rest)))
 102                    (else (error "bad cond" x))))))
 103       ((do)
 104        (match rest
 105          ((((sym init update) ...) (test . result) body ...)
 106           `(@letrec ((_loop (@lambda
 107                              ,sym
 108                              (@if ,(translate test)
 109                                   (@begin ,@(map translate result))
 110                                   (@begin ,@(map translate body)
 111                                           (_loop ,@(map translate update)))))))
 112                     (_loop ,@(map translate init))))))
 113       (else
 114        (let ((prim (and (symbol? head) (symbol-append '@ head))))
 115          (if (and prim (ghil-primitive? prim))
 116              (cons prim (map translate rest))
 117              (cons (translate head) (map translate rest))))))))
 118
 119 \f
 120 ;;;
 121 ;;; Language definition
 122 ;;;
 123
 124 (define-language gscheme
 125   :title        "Guile Scheme"
 126   :version      "0.3"
 127   :reader       read
 128   :expander     expand
 129   :translator   translate
 130   :printer      write
 131   )