mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-11 22:31:12 +02:00
* upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Look for ltdl.h
and ltdl.c in "$(srcdir)". * evalext.c, evalext.h (s_scm_self_evaluating_p): Needed by syntax-case macro fix. * Makefile.am (c-tokenize.c): Look for it in $(srcdir). * syncase.scm, psyntax.ss, psyntax.pp: Imported fixes from trunk. * boot-9.scm (use-syntax): Return *unspecified*.
This commit is contained in:
Mikael Djurfeldt
parent
245b7bf869
commit
98250e31ff
11 changed files with 190 additions and 73 deletions
|
|
@ -1,3 +1,9 @@
|
|||
2003-01-27 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* syncase.scm, psyntax.ss, psyntax.pp: Imported fixes from trunk.
|
||||
|
||||
* boot-9.scm (use-syntax): Return *unspecified*.
|
||||
|
||||
2002-12-12 Marius Vollmer <mvo@zagadka.ping.de>
|
||||
|
||||
* optargs.scm (improper-list-copy): New.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; installed-scm-file
|
||||
|
||||
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003 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
|
||||
|
|
@ -2761,8 +2761,8 @@
|
|||
(set-module-transformer! (current-module)
|
||||
,(car (last-pair spec))))
|
||||
`((set-module-transformer! (current-module) ,spec)))
|
||||
(begin-deprecated
|
||||
(fluid-set! scm:eval-transformer (module-transformer (current-module)))))
|
||||
(fluid-set! scm:eval-transformer (module-transformer (current-module)))
|
||||
*unspecified*)
|
||||
(else
|
||||
(error "use-syntax can only be used at the top level"))))
|
||||
|
||||
|
|
|
|||
File diff suppressed because one or more lines are too long
|
|
@ -1,6 +1,6 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2001, 2003 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
|
||||
|
|
@ -418,9 +418,11 @@
|
|||
((_ 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)
|
||||
|
|
@ -449,12 +451,6 @@
|
|||
(define-syntax build-lexical-var
|
||||
(syntax-rules ()
|
||||
((_ src id) (gensym (symbol->string id)))))
|
||||
|
||||
(define-syntax self-evaluating?
|
||||
(syntax-rules ()
|
||||
((_ e)
|
||||
(let ((x e))
|
||||
(or (boolean? x) (number? x) (string? x) (char? x) (null? x) (keyword? x))))))
|
||||
)
|
||||
|
||||
(define-structure (syntax-object expression wrap))
|
||||
|
|
@ -504,6 +500,7 @@
|
|||
|
||||
;;; <binding> ::= (macro . <procedure>) macros
|
||||
;;; (core . <procedure>) core forms
|
||||
;;; (external-macro . <procedure>) external-macro
|
||||
;;; (begin) begin
|
||||
;;; (define) define
|
||||
;;; (define-syntax) define-syntax
|
||||
|
|
@ -918,6 +915,7 @@
|
|||
;;; 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
|
||||
|
|
@ -971,7 +969,7 @@
|
|||
((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))
|
||||
|
|
@ -1077,15 +1075,20 @@
|
|||
(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
|
||||
|
|
@ -1100,7 +1103,7 @@
|
|||
(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)
|
||||
|
|
@ -1351,7 +1354,7 @@
|
|||
(let ((p (local-eval-hook expanded)))
|
||||
(if (procedure? p)
|
||||
p
|
||||
(syntax-error p "nonprocedure transfomer")))))
|
||||
(syntax-error p "nonprocedure transformer")))))
|
||||
|
||||
(define chi-void
|
||||
(lambda ()
|
||||
|
|
@ -1901,7 +1904,6 @@
|
|||
|
||||
(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
|
||||
|
|
@ -2056,6 +2058,8 @@
|
|||
(match* (unannotate (syntax-object-expression e))
|
||||
p (syntax-object-wrap e) '()))
|
||||
(else (match* (unannotate e) p empty-wrap '())))))
|
||||
|
||||
(set! sc-chi chi)
|
||||
))
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
;;;; Copyright (C) 1997, 2000, 2001 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 1997, 2000, 2001, 2002, 2003 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
|
||||
|
|
@ -44,7 +44,8 @@
|
|||
(define-module (ice-9 syncase)
|
||||
:use-module (ice-9 debug)
|
||||
:use-module (ice-9 threads)
|
||||
:export-syntax (sc-macro define-syntax eval-when fluid-let-syntax
|
||||
:export-syntax (sc-macro define-syntax define-syntax-public
|
||||
eval-when fluid-let-syntax
|
||||
identifier-syntax let-syntax
|
||||
letrec-syntax syntax syntax-case syntax-rules
|
||||
with-syntax
|
||||
|
|
@ -65,40 +66,38 @@
|
|||
|
||||
|
||||
|
||||
(define expansion-eval-closure (make-fluid))
|
||||
|
||||
(define (env->eval-closure env)
|
||||
(or (and env
|
||||
(car (last-pair env)))
|
||||
(module-eval-closure the-root-module)))
|
||||
|
||||
(define sc-macro
|
||||
(procedure->memoizing-macro
|
||||
(lambda (exp env)
|
||||
(sc-expand exp))))
|
||||
(with-fluids ((expansion-eval-closure (env->eval-closure env)))
|
||||
(sc-expand exp)))))
|
||||
|
||||
;;; Exported variables
|
||||
|
||||
(define sc-expand #f)
|
||||
(define sc-expand3 #f)
|
||||
(define sc-chi #f)
|
||||
(define install-global-transformer #f)
|
||||
(define syntax-dispatch #f)
|
||||
(define syntax-error #f)
|
||||
|
||||
(define bound-identifier=? #f)
|
||||
(define datum->syntax-object #f)
|
||||
(define define-syntax sc-macro)
|
||||
(define eval-when sc-macro)
|
||||
(define fluid-let-syntax sc-macro)
|
||||
(define free-identifier=? #f)
|
||||
(define generate-temporaries #f)
|
||||
(define identifier? #f)
|
||||
(define identifier-syntax sc-macro)
|
||||
(define let-syntax sc-macro)
|
||||
(define letrec-syntax sc-macro)
|
||||
(define syntax sc-macro)
|
||||
(define syntax-case sc-macro)
|
||||
(define syntax-object->datum #f)
|
||||
(define syntax-rules sc-macro)
|
||||
(define with-syntax sc-macro)
|
||||
(define include sc-macro)
|
||||
|
||||
(define primitive-syntax '(quote lambda letrec if set! begin define or
|
||||
and let let* cond do quasiquote unquote
|
||||
unquote-splicing case))
|
||||
and let let* cond do quasiquote unquote
|
||||
unquote-splicing case))
|
||||
|
||||
(for-each (lambda (symbol)
|
||||
(set-symbol-property! symbol 'primitive-syntax #t))
|
||||
|
|
@ -135,26 +134,53 @@
|
|||
'())))
|
||||
|
||||
(define the-syncase-module (current-module))
|
||||
(define the-syncase-eval-closure (module-eval-closure the-syncase-module))
|
||||
|
||||
(fluid-set! expansion-eval-closure the-syncase-eval-closure)
|
||||
|
||||
(define (putprop symbol key binding)
|
||||
(let* ((m (current-module))
|
||||
(v (or (module-variable m symbol)
|
||||
(module-make-local-var! m symbol))))
|
||||
(if (symbol-property symbol 'primitive-syntax)
|
||||
(if (eq? (current-module) the-syncase-module)
|
||||
(set-object-property! (module-variable the-root-module symbol)
|
||||
key
|
||||
binding))
|
||||
(let* ((eval-closure (fluid-ref expansion-eval-closure))
|
||||
;; Why not simply do (eval-closure symbol #t)?
|
||||
;; Answer: That would overwrite imported bindings
|
||||
(v (or (eval-closure symbol #f) ;lookup
|
||||
(eval-closure symbol #t) ;create it locally
|
||||
)))
|
||||
;; Don't destroy Guile macros corresponding to
|
||||
;; primitive syntax when syncase boots.
|
||||
(if (not (and (symbol-property symbol 'primitive-syntax)
|
||||
(eq? eval-closure the-syncase-eval-closure)))
|
||||
(variable-set! v sc-macro))
|
||||
;; Properties are tied to variable objects
|
||||
(set-object-property! v key binding)))
|
||||
|
||||
(define (getprop symbol key)
|
||||
(let* ((m (current-module))
|
||||
(v (module-variable m symbol)))
|
||||
(and v (or (object-property v key)
|
||||
(let ((root-v (module-local-variable the-root-module symbol)))
|
||||
(and (equal? root-v v)
|
||||
(object-property root-v key)))))))
|
||||
(let* ((v ((fluid-ref expansion-eval-closure) symbol #f)))
|
||||
(and v
|
||||
(or (object-property v key)
|
||||
(and (variable-bound? v)
|
||||
(macro? (variable-ref v))
|
||||
(macro-transformer (variable-ref v)) ;non-primitive
|
||||
guile-macro)))))
|
||||
|
||||
(define guile-macro
|
||||
(cons 'external-macro
|
||||
(lambda (e r w s)
|
||||
(let ((e (syntax-object->datum e)))
|
||||
(if (symbol? e)
|
||||
;; pass the expression through
|
||||
e
|
||||
(let* ((eval-closure (fluid-ref expansion-eval-closure))
|
||||
(m (variable-ref (eval-closure (car e) #f))))
|
||||
(if (eq? (macro-type m) 'syntax)
|
||||
;; pass the expression through
|
||||
e
|
||||
;; perform Guile macro transform
|
||||
(let ((e ((macro-transformer m)
|
||||
e
|
||||
(append r (list eval-closure)))))
|
||||
(if (null? r)
|
||||
(sc-expand e)
|
||||
(sc-chi e r w))))))))))
|
||||
|
||||
(define generated-symbols (make-weak-key-hash-table 1019))
|
||||
|
||||
|
|
@ -237,4 +263,18 @@
|
|||
'*sc-expander*
|
||||
'(define))))
|
||||
|
||||
(define syncase sc-expand)
|
||||
(define (syncase exp)
|
||||
(with-fluids ((expansion-eval-closure
|
||||
(module-eval-closure (current-module))))
|
||||
(sc-expand exp)))
|
||||
|
||||
(set-module-transformer! the-syncase-module syncase)
|
||||
|
||||
(define-syntax define-syntax-public
|
||||
(syntax-rules ()
|
||||
((_ name rules ...)
|
||||
(begin
|
||||
;(eval-case ((load-toplevel) (export-syntax name)))
|
||||
(define-syntax name rules ...)))))
|
||||
|
||||
(fluid-set! expansion-eval-closure (env->eval-closure #f))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,8 @@
|
|||
2003-01-27 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* upstream/Makefile.am (ltdl.h.diff, ltdl.c.diff): Look for ltdl.h
|
||||
and ltdl.c in "$(srcdir)".
|
||||
|
||||
2002-10-25 Marius Vollmer <marius.vollmer@uni-dortmund.de>
|
||||
|
||||
* upstream/ltdl.c: New copy from libtool 1.4.3.
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
## Process this file with Automake to create Makefile.in
|
||||
##
|
||||
## Copyright (C) 2002 Free Software Foundation, Inc.
|
||||
## Copyright (C) 2002, 2003 Free Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
|
|
@ -34,7 +34,7 @@ ETAGS_ARGS = --regex='/SCM_\(GLOBAL_\)?\(G?PROC\|G?PROC1\|SYMBOL\|VCELL\|CONST_L
|
|||
EXTRA_DIST := ltdl.h ltdl.c ltdl.h.diff ltdl.c.diff
|
||||
BUILT_SOURCES := ltdl.h.diff ltdl.c.diff
|
||||
|
||||
ltdl.h.diff: ltdl.h $(srcdir)/../raw-ltdl.h
|
||||
ltdl.h.diff: $(srcdir)/ltdl.h $(srcdir)/../raw-ltdl.h
|
||||
cp $(srcdir)/../raw-ltdl.h raw-ltdl.guilemod.h.tmp
|
||||
perl -pi \
|
||||
-e 's/SCMLTXT/extern/go;' \
|
||||
|
|
@ -43,10 +43,10 @@ ltdl.h.diff: ltdl.h $(srcdir)/../raw-ltdl.h
|
|||
-e 's/SCM_INSERTED_DLSYMLIST_STRUCT_DECL //go;' \
|
||||
raw-ltdl.guilemod.h.tmp
|
||||
mv raw-ltdl.guilemod.h.tmp raw-ltdl.guilemod.h
|
||||
diff -ru ltdl.h raw-ltdl.guilemod.h > ltdl.h.diff; \
|
||||
diff -ru $(srcdir)/ltdl.h raw-ltdl.guilemod.h > ltdl.h.diff; \
|
||||
test "$$?" -eq 1
|
||||
|
||||
ltdl.c.diff: ltdl.c $(srcdir)/../raw-ltdl.c
|
||||
ltdl.c.diff: $(srcdir)/ltdl.c $(srcdir)/../raw-ltdl.c
|
||||
cp $(srcdir)/../raw-ltdl.c raw-ltdl.guilemod.c.tmp
|
||||
perl -pi \
|
||||
-e 's/SCMLTXT/extern/go;' \
|
||||
|
|
@ -55,7 +55,7 @@ ltdl.c.diff: ltdl.c $(srcdir)/../raw-ltdl.c
|
|||
-e 's/SCM_INSERTED_DLSYMLIST_STRUCT_DECL //go;' \
|
||||
raw-ltdl.guilemod.c.tmp
|
||||
mv raw-ltdl.guilemod.c.tmp raw-ltdl.guilemod.c
|
||||
diff -ru ltdl.c raw-ltdl.guilemod.c > ltdl.c.diff; \
|
||||
diff -ru $(srcdir)/ltdl.c raw-ltdl.guilemod.c > ltdl.c.diff; \
|
||||
test "$$?" -eq 1
|
||||
|
||||
CLEANFILES := \
|
||||
|
|
|
|||
|
|
@ -1,3 +1,10 @@
|
|||
2003-01-27 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* evalext.c, evalext.h (s_scm_self_evaluating_p): Needed by
|
||||
syntax-case macro fix.
|
||||
|
||||
* Makefile.am (c-tokenize.c): Look for it in $(srcdir).
|
||||
|
||||
2003-01-08 Mikael Djurfeldt <djurfeldt@nada.kth.se>
|
||||
|
||||
* goops.c (scm_sys_prep_layout_x): Bugfix: Only create layout for
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
## Process this file with Automake to create Makefile.in
|
||||
##
|
||||
## Copyright (C) 1998, 1999, 2000, 2001, 2002 Free Software Foundation, Inc.
|
||||
## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003 Free Software Foundation, Inc.
|
||||
##
|
||||
## This file is part of GUILE.
|
||||
##
|
||||
|
|
@ -256,8 +256,8 @@ guile-procedures.txt: guile-procedures.texi
|
|||
|
||||
endif
|
||||
|
||||
c-tokenize.c: c-tokenize.lex
|
||||
flex -t c-tokenize.lex > $@ || { rm $@; false; }
|
||||
c-tokenize.c: $(srcdir)/c-tokenize.lex
|
||||
flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
|
||||
|
||||
schemelibdir = $(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)
|
||||
schemelib_DATA = guile-procedures.txt
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998,1999,2000,2001, 2003 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
|
||||
|
|
@ -143,6 +143,60 @@ scm_m_undefine (SCM x, SCM env)
|
|||
|
||||
SCM_REGISTER_PROC (s_map_in_order, "map-in-order", 2, 0, 1, scm_map);
|
||||
|
||||
#define scm_tcs_struct scm_tcs_cons_gloc
|
||||
|
||||
SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return #t for objects which Guile considers self-evaluating")
|
||||
#define FUNC_NAME s_scm_self_evaluating_p
|
||||
{
|
||||
switch (SCM_ITAG3 (obj))
|
||||
{
|
||||
case scm_tc3_int_1:
|
||||
case scm_tc3_int_2:
|
||||
/* inum */
|
||||
return SCM_BOOL_T;
|
||||
case scm_tc3_imm24:
|
||||
/* characters, booleans, other immediates */
|
||||
return SCM_BOOL (!SCM_NULLP (obj));
|
||||
case scm_tc3_cons:
|
||||
switch (SCM_TYP7 (obj))
|
||||
{
|
||||
case scm_tcs_closures:
|
||||
case scm_tc7_vector:
|
||||
case scm_tc7_wvect:
|
||||
#ifdef HAVE_ARRAYS
|
||||
case scm_tc7_bvect:
|
||||
case scm_tc7_byvect:
|
||||
case scm_tc7_svect:
|
||||
case scm_tc7_ivect:
|
||||
case scm_tc7_uvect:
|
||||
case scm_tc7_fvect:
|
||||
case scm_tc7_dvect:
|
||||
case scm_tc7_cvect:
|
||||
#ifdef HAVE_LONG_LONGS
|
||||
case scm_tc7_llvect:
|
||||
#endif
|
||||
#endif
|
||||
case scm_tc7_string:
|
||||
case scm_tc7_smob:
|
||||
case scm_tc7_cclo:
|
||||
case scm_tc7_pws:
|
||||
case scm_tcs_subrs:
|
||||
case scm_tcs_struct:
|
||||
return SCM_BOOL_T;
|
||||
default:
|
||||
return SCM_BOOL_F;
|
||||
}
|
||||
}
|
||||
SCM_MISC_ERROR ("Internal error: Object ~S has unknown type",
|
||||
scm_list_1 (obj));
|
||||
return SCM_UNSPECIFIED; /* never reached */
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
#undef scm_tcs_struct
|
||||
|
||||
void
|
||||
scm_init_evalext ()
|
||||
{
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
#ifndef EVALEXTH
|
||||
#define EVALEXTH
|
||||
/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc.
|
||||
/* Copyright (C) 1998, 1999, 2000, 2003 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
|
||||
|
|
@ -51,6 +51,7 @@
|
|||
extern SCM scm_m_generalized_set_x (SCM xorig, SCM env);
|
||||
extern SCM scm_definedp (SCM sym, SCM env);
|
||||
extern SCM scm_m_undefine (SCM x, SCM env);
|
||||
extern SCM scm_self_evaluating_p (SCM obj);
|
||||
extern void scm_init_evalext (void);
|
||||
|
||||
#endif /* EVALEXTH */
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue