mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-14 01:30:19 +02:00
53befeb700
(Not quite finished, the following will be done tomorrow. module/srfi/*.scm module/rnrs/*.scm module/scripts/*.scm testsuite/*.scm guile-readline/* )
80 lines
2.4 KiB
Scheme
80 lines
2.4 KiB
Scheme
;;; R5RS syntax expander
|
|
|
|
;; Copyright (C) 2001 Free Software Foundation, Inc.
|
|
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library 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
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Code:
|
|
|
|
(define-module (language r5rs expand)
|
|
#:export (expand void
|
|
identifier? free-identifier=? bound-identifier=?
|
|
generate-temporaries datum->syntax-object syntax-object->datum))
|
|
|
|
(define sc-expand #f)
|
|
(define $sc-put-cte #f)
|
|
(define $syntax-dispatch #f)
|
|
(define syntax-rules #f)
|
|
(define syntax-error #f)
|
|
(define identifier? #f)
|
|
(define free-identifier=? #f)
|
|
(define bound-identifier=? #f)
|
|
(define generate-temporaries #f)
|
|
(define datum->syntax-object #f)
|
|
(define syntax-object->datum #f)
|
|
|
|
(define void (lambda () (if #f #f)))
|
|
|
|
(define andmap
|
|
(lambda (f first . rest)
|
|
(or (null? first)
|
|
(if (null? rest)
|
|
(let andmap ((first first))
|
|
(let ((x (car first)) (first (cdr first)))
|
|
(if (null? first)
|
|
(f x)
|
|
(and (f x) (andmap first)))))
|
|
(let andmap ((first first) (rest rest))
|
|
(let ((x (car first))
|
|
(xr (map car rest))
|
|
(first (cdr first))
|
|
(rest (map cdr rest)))
|
|
(if (null? first)
|
|
(apply f (cons x xr))
|
|
(and (apply f (cons x xr)) (andmap first rest)))))))))
|
|
|
|
(define ormap
|
|
(lambda (proc list1)
|
|
(and (not (null? list1))
|
|
(or (proc (car list1)) (ormap proc (cdr list1))))))
|
|
|
|
(define putprop set-symbol-property!)
|
|
(define getprop symbol-property)
|
|
(define remprop symbol-property-remove!)
|
|
|
|
(define syncase-module (current-module))
|
|
(define guile-eval eval)
|
|
(define (eval x)
|
|
(if (and (pair? x) (equal? (car x) "noexpand"))
|
|
(cdr x)
|
|
(guile-eval x syncase-module)))
|
|
|
|
(define guile-error error)
|
|
(define (error who format-string why what)
|
|
(guile-error why what))
|
|
|
|
(load "psyntax.pp")
|
|
|
|
(define expand sc-expand)
|