diff options
Diffstat (limited to 'syntest2.scm')
| -rw-r--r-- | syntest2.scm | 186 |
1 files changed, 186 insertions, 0 deletions
diff --git a/syntest2.scm b/syntest2.scm new file mode 100644 index 0000000..68633cf --- /dev/null +++ b/syntest2.scm @@ -0,0 +1,186 @@ +;; Copyright (C) 2000, 2001, 2002 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 software; see the file COPYING. If not, write to +;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. +;; +;; As a special exception, the Free Software Foundation gives permission +;; for additional uses of the text contained in its release of GUILE. +;; +;; The exception is that, if you link the GUILE library with other files +;; to produce an executable, this does not by itself cause the +;; resulting executable to be covered by the GNU General Public License. +;; Your use of that executable is in no way restricted on account of +;; linking the GUILE library code into it. +;; +;; This exception does not however invalidate any other reasons why +;; the executable file might be covered by the GNU General Public License. +;; +;; This exception applies only to the code released by the +;; Free Software Foundation under the name GUILE. If you copy +;; code from other Free Software Foundation releases into a copy of +;; GUILE, as the General Public License permits, the exception does +;; not apply to the code that you add in this way. To avoid misleading +;; anyone as to the status of such modified files, you must delete +;; this exception notice from them. +;; +;; If you write modifications of your own for GUILE, it is your choice +;; whether to permit this exception to apply to your modifications. +;; If you do not wish that, delete this exception notice. + +(require 'macro) + +;; Redefine some derived special forms. + +(define-syntax let + (syntax-rules () + ((let ((?name ?val) ...) . ?body) + ((lambda (?name ...) . ?body) ?val ...)) + ((let ?proc ((?name ?val) ...) . ?body) + (let ((?proc #f) + (?name ?val) ...) + (set! ?proc (lambda (?name ...) . ?body)) + (?proc ?name ...))))) + +(define-syntax let* + (syntax-rules () + ((let* () . ?body) + ((lambda () . ?body))) + ((let* ((?name ?val)) . ?body) + ((lambda (?name) . ?body) ?val)) + ((let* ((?name ?val) ?binding ...) . ?body) + (let* ((?name ?val)) + (let* (?binding ...) . ?body))))) + +(define-syntax letrec + (syntax-rules () + ((letrec ((?name ?val) ...) . ?body) + (let ((?name #f) ...) + (set! ?name ?val) ... + (let () . ?body))))) + +(define-syntax and + (syntax-rules () + ((and) #t) + ((and ?exp) + (let ((x ?exp)) + (if x x #f))) + ((and ?exp . ?rest) + (let ((x ?exp)) + (if x (and . ?rest) #f))))) + +(define-syntax or + (syntax-rules () + ((or) #f) + ((or ?exp) + (let ((x ?exp)) + (if x x #f))) + ((or ?exp . ?rest) + (let ((x ?exp)) + (if x x (or . ?rest)))))) + +(define (force promise) + (promise)) + +(define (make-promise proc) + (let ((result #f)) + (lambda () + (if result (car result) + (let ((x (proc))) + (if result (car result) + (begin (set! result (list x)) + x))))))) + +(define-syntax delay + (syntax-rules () + ((delay ?expr) + (make-promise (lambda () ?expr))))) + +(define-syntax do + (syntax-rules () + ((do ((?name ?init . ?step) ...) + (?test . ?result) + ?body ...) + (let-syntax ((do-step (syntax-rules () + ((do-step ?n) ?n) + ((do-step ?n ?s) ?s))) + (do-result (syntax-rules () + ((do-result) (if #f #f)) + ((do-result . ?r) (begin . ?r))))) + (let loop ((?name ?init) ...) + (if ?test + (do-result . ?result) + (begin ?body ... + (loop (do-step ?name . ?step) ...)))))))) + +(define-syntax case + (syntax-rules (else) + ((case ?x (else . ?conseq)) + (begin . ?conseq)) + ((case ?x (?lst . ?conseq)) + (if (memv ?x '?lst) (begin . ?conseq))) + ((case ?x (?lst . ?conseq) . ?rest) + (if (memv ?x '?lst) + (begin . ?conseq) + (case ?x . ?rest))))) + +(define-syntax cond + (syntax-rules (else =>) + ((cond ?clause0 . ?clauses) + (letrec-syntax + ((cond-aux + (syntax-rules (else =>) + ((cond-aux) (if #f #f)) + ((cond-aux (else . ?conseq)) + (begin . ?conseq)) + ((cond-aux (?test => ?proc) . ?rest) + (let ((val ?test)) + (if val (?proc val) (cond-aux . ?rest)))) + ((cond-aux (?test) . ?rest) + (or ?test (cond-aux . ?rest))) + ((cond-aux (?test . ?conseq) . ?rest) + (if ?test (begin . ?conseq) (cond-aux . ?rest)))))) + (cond-aux ?clause0 . ?clauses))))) + +;; This may fail if you redefine CONS, LIST, APPEND, or LIST->VECTOR +;; It uses the (... ...) escape. +;; All forms are evaluated inside a LETREC-SYNTAX body (is this a problem?). + +(define-syntax quasiquote + (syntax-rules () + ((_ ?template) + (letrec-syntax + ((qq + (syntax-rules (unquote unquote-splicing quasiquote) + ((_ (unquote ?form) ()) + ?form) + ((_ (unquote ?form) (?depth)) + (list 'unquote (qq ?form ?depth))) + ((_ (quasiquote ?form) ?depth) + (list 'quasiquote (qq ?form (?depth)))) + ((_ ((unquote-splicing ?form) . ?rest) ()) + (append ?form (qq ?rest ()))) + ((_ ((unquote-splicing ?form) . ?rest) (?depth)) + (append (list 'unquote-splicing (qq ?form ?depth)) + (qq ?rest (?depth)))) + ((_ (?car . ?cdr) ?depth) + (cons (qq ?car ?depth) (qq ?cdr ?depth))) + ((_ #(?elt (... ...)) ?depth) + (list->vector (qq (?elt (... ...)) ?depth))) + ((_ ?atom ?depth) + '?atom)))) + (qq ?template ()))))) + +;;(load "r4rstest.scm") + + |