+;;;; -*-scheme-*-
+;;;;
+;;;; Copyright (C) 2001, 2003 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 2.1 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
+;;;;
+\f
+
;;; Portable implementation of syntax-case
;;; Extracted from Chez Scheme Version 5.9f
;;; Authors: R. Kent Dybvig, Oscar Waddell, Bob Hieb, Carl Bruggeman
+;;; Modified by Mikael Djurfeldt <djurfeldt@nada.kth.se> according
+;;; to the ChangeLog distributed in the same directory as this file:
+;;; 1997-08-19, 1997-09-03, 1997-09-10, 2000-08-13, 2000-08-24,
+;;; 2000-09-12, 2001-03-08
+
;;; Copyright (c) 1992-1997 Cadence Research Systems
;;; Permission to copy this software, in whole or in part, to use this
;;; software for any lawful purpose, and to redistribute this software
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
;;; NATURE WHATSOEVER.
-
;;; Before attempting to port this code to a new implementation of
;;; Scheme, please read the notes below carefully.
((_ src name) name)
((_ src level name) name)))
-(define-syntax build-data
- (syntax-rules ()
- ((_ src exp) `',exp)))
+(define (build-data src exp)
+ (if (and (self-evaluating? exp)
+ (not (vector? exp)))
+ exp
+ (list 'quote exp)))
(define build-sequence
(lambda (src exps)
(define-syntax build-lexical-var
(syntax-rules ()
- ((_ src id) (gensym id generated-symbols))))
-
-(define-syntax self-evaluating?
- (syntax-rules ()
- ((_ e)
- (let ((x e))
- (or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
+ ((_ src id) (gensym (symbol->string id)))))
)
(define-structure (syntax-object expression wrap))
;;; <binding> ::= (macro . <procedure>) macros
;;; (core . <procedure>) core forms
+;;; (external-macro . <procedure>) external-macro
;;; (begin) begin
;;; (define) define
;;; (define-syntax) define-syntax
;;; type value explanation
;;; -------------------------------------------------------------------
;;; core procedure core form (including singleton)
+;;; external-macro procedure external macro
;;; lexical name lexical variable reference
;;; global name global variable reference
;;; begin none begin keyword
((macro)
(syntax-type (chi-macro (binding-value b) e r w rib)
r empty-wrap s rib))
- ((core) (values type (binding-value b) e w s))
+ ((core external-macro) (values type (binding-value b) e w s))
((local-syntax)
(values 'local-syntax-form (binding-value b) e w s))
((begin) (values 'begin-form #f e w s))
(chi-install-global n (chi e r w))))
(chi-void)))))
((define-form)
- (let ((n (id-var-name value w)))
- (case (binding-type (lookup n r))
+ (let* ((n (id-var-name value w))
+ (type (binding-type (lookup n r))))
+ (case type
((global)
(eval-if-c&e m
(build-global-definition s n (chi e r w))))
((displaced-lexical)
(syntax-error (wrap value w) "identifier out of context"))
- (else (syntax-error (wrap value w)
- "cannot define keyword at top level")))))
+ (else
+ (if (eq? type 'external-macro)
+ (eval-if-c&e m
+ (build-global-definition s n (chi e r w)))
+ (syntax-error (wrap value w)
+ "cannot define keyword at top level"))))))
(else (eval-if-c&e m (chi-expr type value e r w s))))))))
(define chi
(case type
((lexical)
(build-lexical-reference 'value s value))
- ((core) (value e r w s))
+ ((core external-macro) (value e r w s))
((lexical-call)
(chi-application
(build-lexical-reference 'fun (source-annotation (car e)) value)
(let ((p (local-eval-hook expanded)))
(if (procedure? p)
p
- (syntax-error p "nonprocedure transfomer")))))
+ (syntax-error p "nonprocedure transformer")))))
(define chi-void
(lambda ()
(syntax-error (wrap (syntax id) w)
"identifier out of context"))
(else (syntax-error (source-wrap e w s)))))))
+ ((_ (getter arg ...) val)
+ (build-application s
+ (chi (syntax (setter getter)) r w)
+ (map (lambda (e) (chi e r w))
+ (syntax (arg ... val)))))
(_ (syntax-error (source-wrap e w s))))))
(global-extend 'begin 'begin '())
(set! datum->syntax-object
(lambda (id datum)
- (arg-check nonsymbol-id? id 'datum->syntax-object)
(make-syntax-object datum (syntax-object-wrap id))))
(set! syntax-object->datum
(match* (unannotate (syntax-object-expression e))
p (syntax-object-wrap e) '()))
(else (match* (unannotate e) p empty-wrap '())))))
+
+(set! sc-chi chi)
))
)
HCoop / bpt / guile.git / blobdiff