[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, elisp, updated. release_1-9-0-47-g50ab
|
From: |
Daniel Kraft |
|
Subject: |
[Guile-commits] GNU Guile branch, elisp, updated. release_1-9-0-47-g50abfe7 |
|
Date: |
Mon, 13 Jul 2009 13:46:02 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=50abfe7649bd2963248b791ab318ba5187688339
The branch, elisp has been updated
via 50abfe7649bd2963248b791ab318ba5187688339 (commit)
via 3a4b86357ec612bf765291102483d73830033f6e (commit)
via d221c18bc0f6d8c0702a5dd063d144bedf000420 (commit)
via 9d09e928cd4b54e0fbb3296a2bf63de62f1cb049 (commit)
via 344927c3f8e2cc9e9587b490bf914428ecca723a (commit)
via 7c957b8657a510395fc451ae4a8e7e3fe5a643ad (commit)
via fdfb36de84f717bfd1e2f0d511434df03aa3105e (commit)
via a43167392465fb32a5c60f1a6a9f0064c08cbe3d (commit)
via 40f892156acba9cac990d2a53333fc41cefcd507 (commit)
via dd57ddd5ede6d3d9a736b2b48455fbd87da51e3a (commit)
via 0a94eb002eba6539879f2cddf3e45fb25976af8d (commit)
from 4530432e0160fd677fb19078a8d139677e88fb91 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 50abfe7649bd2963248b791ab318ba5187688339
Author: Daniel Kraft <address@hidden>
Date: Mon Jul 13 15:43:53 2009 +0200
Lambda expressions in elisp, but not yet function calls.
* module/language/elisp/README: Document this.
* module/language/elisp/compile-tree-il.scm: Implement lambda expressions.
commit 3a4b86357ec612bf765291102483d73830033f6e
Author: Daniel Kraft <address@hidden>
Date: Tue Jul 7 19:38:25 2009 +0200
Implemented let and let* in elisp.
* module/language/elisp/README: Document it.
* module/language/elisp/compile-tree-il.scm: Implement let and let*.
commit d221c18bc0f6d8c0702a5dd063d144bedf000420
Author: Daniel Kraft <address@hidden>
Date: Tue Jul 7 17:26:22 2009 +0200
Implemented while construct in elisp.
* module/language/elisp/README: Document this.
* module/language/elisp/compile-tree-il.scm: Implement while construct.
commit 9d09e928cd4b54e0fbb3296a2bf63de62f1cb049
Merge: 344927c3f8e2cc9e9587b490bf914428ecca723a
7c957b8657a510395fc451ae4a8e7e3fe5a643ad
Author: Daniel Kraft <address@hidden>
Date: Sat Jul 4 11:09:38 2009 +0200
Merge branch 'master' of git://git.savannah.gnu.org/guile into elisp
commit 344927c3f8e2cc9e9587b490bf914428ecca723a
Author: Daniel Kraft <address@hidden>
Date: Fri Jul 3 23:00:12 2009 +0200
Implemented fluid-based variable references and setting using setq.
* module/language/elisp/README: Document this.
* module/language/elisp/compile-tree-il.scm: Implement variable references,
setq
* module/language/elisp/runtime.scm: New file for runtime definitions.
* module/language/elisp/runtime/function-slot.scm: Ditto.
* module/language/elisp/runtime/value-slot.scm: Ditto.
commit fdfb36de84f717bfd1e2f0d511434df03aa3105e
Author: Daniel Kraft <address@hidden>
Date: Thu Jul 2 21:22:25 2009 +0200
Implemented elisp's or form.
* module/language/elisp/README: Document this.
* module/language/elisp/compile-tree-il.scm: Implement or.
commit a43167392465fb32a5c60f1a6a9f0064c08cbe3d
Author: Daniel Kraft <address@hidden>
Date: Thu Jul 2 21:10:38 2009 +0200
For elisp's (cond ...) and (condition) forms without body, return the
condition as value.
* compile-tree-il.scm: Fix compilation of (cond ...) for bodyless
conditions.
-----------------------------------------------------------------------
Summary of changes:
NEWS | 1 +
doc/ref/api-compound.texi | 22 +-
libguile/fports.c | 44 +---
libguile/fports.h | 4 +-
libguile/numbers.c | 19 +-
libguile/objcodes.c | 6 +-
libguile/ports.c | 12 +-
module/language/elisp/README | 17 +-
module/language/elisp/compile-tree-il.scm | 331 +++++++++++++++++++-
.../vm/objcode.scm => language/elisp/runtime.scm} | 14 +-
.../elisp/runtime/function-slot.scm} | 10 +-
.../elisp/runtime/value-slot.scm} | 10 +-
test-suite/tests/numbers.test | 9 +-
13 files changed, 377 insertions(+), 122 deletions(-)
copy module/{system/vm/objcode.scm => language/elisp/runtime.scm} (75%)
copy module/{system/vm/objcode.scm =>
language/elisp/runtime/function-slot.scm} (75%)
copy module/{system/vm/objcode.scm => language/elisp/runtime/value-slot.scm}
(75%)
diff --git a/NEWS b/NEWS
index 593d6c2..a33c490 100644
--- a/NEWS
+++ b/NEWS
@@ -560,6 +560,7 @@ Changes in 1.8.7 (since 1.8.6)
** With GCC, always compile with `-mieee' on `alpha*' and `sh*'
** Better diagnose broken `(strftime "%z" ...)' in `time.test' (bug #24130)
** Fix parsing of SRFI-88/postfix keywords longer than 128 characters
+** Fix reading of complex numbers where both parts are inexact decimals
** Allow @ macro to work with (ice-9 syncase)
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index b3997ef..7eccb86 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -2358,21 +2358,13 @@ the danger of a deadlock. In a multi-threaded program,
you will need
additional synchronization to avoid modifying reserved arrays.)
You must take care to always unreserve an array after reserving it,
-also in the presence of non-local exits. To simplify this, reserving
-and unreserving work like a dynwind context (@pxref{Dynamic Wind}): a
-call to @code{scm_array_get_handle} can be thought of as beginning a
-dynwind context and @code{scm_array_handle_release} as ending it.
-When a non-local exit happens between these two calls, the array is
-implicitely unreserved.
-
-That is, you need to properly pair reserving and unreserving in your
-code, but you don't need to worry about non-local exits.
-
-These calls and other pairs of calls that establish dynwind contexts
-need to be properly nested. If you begin a context prior to reserving
-an array, you need to unreserve the array before ending the context.
-Likewise, when reserving two or more arrays in a certain order, you
-need to unreserve them in the opposite order.
+even in the presence of non-local exits. If a non-local exit can
+happen between these two calls, you should install a dynwind context
+that releases the array when it is left (@pxref{Dynamic Wind}).
+
+In addition, array reserving and unreserving must be properly
+paired. For instance, when reserving two or more arrays in a certain
+order, you need to unreserve them in the opposite order.
Once you have reserved an array and have retrieved the pointer to its
elements, you must figure out the layout of the elements in memory.
diff --git a/libguile/fports.c b/libguile/fports.c
index f6e0556..cfb8b25 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -610,8 +610,8 @@ fport_fill_input (SCM port)
}
}
-static off_t_or_off64_t
-fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
+static scm_t_off
+fport_seek (SCM port, scm_t_off offset, int whence)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_t_fport *fp = SCM_FSTREAM (port);
@@ -662,39 +662,6 @@ fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset,
int whence)
return result;
}
-/* If we've got largefile and off_t isn't already off64_t then
- fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
- the port descriptor.
-
- Otherwise if no largefile, or off_t is the same as off64_t (which is the
- case on NetBSD apparently), then fport_seek_or_seek64 is right to be
- fport_seek already. */
-
-#if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
-static scm_t_off
-fport_seek (SCM port, scm_t_off offset, int whence)
-{
- off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
- if (rv > OFF_T_MAX || rv < OFF_T_MIN)
- {
- errno = EOVERFLOW;
- scm_syserror ("fport_seek");
- }
- return (scm_t_off) rv;
-
-}
-#else
-#define fport_seek fport_seek_or_seek64
-#endif
-
-/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
-SCM
-scm_i_fport_seek (SCM port, SCM offset, int how)
-{
- return scm_from_off_t_or_off64_t
- (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
-}
-
static void
fport_truncate (SCM port, scm_t_off length)
{
@@ -704,13 +671,6 @@ fport_truncate (SCM port, scm_t_off length)
scm_syserror ("ftruncate");
}
-int
-scm_i_fport_truncate (SCM port, SCM length)
-{
- scm_t_fport *fp = SCM_FSTREAM (port);
- return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
-}
-
/* helper for fport_write: try to write data, using multiple system
calls if required. */
#define FUNC_NAME "write_all"
diff --git a/libguile/fports.h b/libguile/fports.h
index 2687504..cbef0f8 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -3,7 +3,7 @@
#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 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
@@ -59,8 +59,6 @@ SCM_INTERNAL void scm_init_fports (void);
/* internal functions */
SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);
-SCM_INTERNAL int scm_i_fport_truncate (SCM, SCM);
-SCM_INTERNAL SCM scm_i_fport_seek (SCM, SCM, int);
#endif /* SCM_FPORTS_H */
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 83b3f7c..c7e0981 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -2733,6 +2733,10 @@ mem2ureal (const char* mem, size_t len, unsigned int
*p_idx,
unsigned int idx = *p_idx;
SCM result;
+ /* Start off believing that the number will be exact. This changes
+ to INEXACT if we see a decimal point or a hash. */
+ enum t_exactness x = EXACT;
+
if (idx == len)
return SCM_BOOL_F;
@@ -2744,8 +2748,6 @@ mem2ureal (const char* mem, size_t len, unsigned int
*p_idx,
if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
{
- enum t_exactness x = EXACT;
-
/* Cobble up the fractional part. We might want to set the
NaN's mantissa from it. */
idx += 4;
@@ -2764,11 +2766,10 @@ mem2ureal (const char* mem, size_t len, unsigned int
*p_idx,
return SCM_BOOL_F;
else
result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len,
- p_idx, p_exactness);
+ p_idx, &x);
}
else
{
- enum t_exactness x = EXACT;
SCM uinteger;
uinteger = mem2uinteger (mem, len, &idx, radix, &x);
@@ -2800,10 +2801,16 @@ mem2ureal (const char* mem, size_t len, unsigned int
*p_idx,
result = uinteger;
*p_idx = idx;
- if (x == INEXACT)
- *p_exactness = x;
}
+ /* Update *p_exactness if the number just read was inexact. This is
+ important for complex numbers, so that a complex number is
+ treated as inexact overall if either its real or imaginary part
+ is inexact.
+ */
+ if (x == INEXACT)
+ *p_exactness = x;
+
/* When returning an inexact zero, make sure it is represented as a
floating point value so that we can change its sign.
*/
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 03ea0b8..4f21971 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -70,11 +70,11 @@ make_objcode_by_mmap (int fd)
if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
{
+ SCM args = scm_list_1 (scm_from_locale_stringn
+ (addr, strlen (OBJCODE_COOKIE)));
(void) close (fd);
(void) munmap (addr, st.st_size);
- scm_misc_error (FUNC_NAME, "bad header on object file: ~s",
- scm_list_1 (scm_from_locale_stringn
- (addr, strlen (OBJCODE_COOKIE))));
+ scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
}
data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
diff --git a/libguile/ports.c b/libguile/ports.c
index 98207b0..627fd3f 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1390,12 +1390,7 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
- if (SCM_OPFPORTP (fd_port))
- {
- /* go direct to fport code to allow 64-bit offsets */
- return scm_i_fport_seek (fd_port, offset, how);
- }
- else if (SCM_OPPORTP (fd_port))
+ if (SCM_OPPORTP (fd_port))
{
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
@@ -1488,11 +1483,6 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
c_length));
}
- else if (SCM_OPOUTFPORTP (object))
- {
- /* go direct to fport code to allow 64-bit offsets */
- rv = scm_i_fport_truncate (object, length);
- }
else if (SCM_OPOUTPORTP (object))
{
off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
diff --git a/module/language/elisp/README b/module/language/elisp/README
index 160df35..47ff7c5 100644
--- a/module/language/elisp/README
+++ b/module/language/elisp/README
@@ -7,17 +7,24 @@ as status information.
Already implemented:
* progn
* if, cond
- * and
+ * and, or
* quote
+ * referencing and setting (setq) variables
+ * while
+ * let, let*
+ * lambda expressions
Especially still missing:
* other progX forms, will be done in macros
* where, unless, will be done in macros
- * or
- * while, other loops using macros
+ * dolist, dotimes using macros
* catch/throw, unwind-protect
* real elisp reader instead of Scheme's
- * handling of variables: setq, referencing, let -- using fluids for scoping
+ * set based on setq
+ * makunbound, boundp
+ * automatic creation of fluids when needed
* macros
* general primitives (+, -, *, cons, ...)
- * functions, lambdas
+ * function calls
+ * fset & friends
+ * defvar, defun
diff --git a/module/language/elisp/compile-tree-il.scm
b/module/language/elisp/compile-tree-il.scm
index dbc1004..85a8627 100644
--- a/module/language/elisp/compile-tree-il.scm
+++ b/module/language/elisp/compile-tree-il.scm
@@ -35,9 +35,208 @@
props))))
-; Value to use for Elisp's nil.
+; Value to use for Elisp's nil and t.
-(define (nil-value loc) (make-const loc %nil))
+(define (nil-value loc) (make-const loc #f))
+(define (t-value loc) (make-const loc #t))
+
+
+; Modules that contain the value and function slot bindings.
+
+(define runtime '(language elisp runtime))
+(define value-slot '(language elisp runtime value-slot))
+(define function-slot '(language elisp runtime function-slot))
+
+
+; Build a call to a primitive procedure nicely.
+
+(define (call-primitive loc sym . args)
+ (make-application loc (make-primitive-ref loc sym) args))
+
+
+; Error reporting routine for syntax/compilation problems or build code for
+; a runtime-error output.
+
+(define (report-error loc . args)
+ (apply error args))
+
+(define (runtime-error loc msg . args)
+ (make-application loc (make-primitive-ref loc 'error)
+ (cons (make-const loc msg) args)))
+
+
+; Generate code to ensure a fluid is there for further use of a given symbol.
+
+(define (ensure-fluid! loc sym module)
+ ; FIXME: Do this!
+ (make-void loc))
+
+
+; Generate code to reference a fluid saved variable.
+
+(define (reference-variable loc sym module)
+ (make-sequence loc
+ (list (ensure-fluid! loc sym module)
+ (call-primitive loc 'fluid-ref
+ (make-module-ref loc module sym #t)))))
+
+
+; Reference a variable and error if the value is void.
+
+(define (reference-with-check loc sym module)
+ (let ((var (gensym)))
+ (make-let loc '(value) `(,var) `(,(reference-variable loc sym module))
+ (make-conditional loc
+ (call-primitive loc 'eq?
+ (make-module-ref loc runtime 'void #t)
+ (make-lexical-ref loc 'value var))
+ (runtime-error loc "variable is void:" (make-const loc sym))
+ (make-lexical-ref loc 'value var)))))
+
+
+; Generate code to set a fluid saved variable.
+
+(define (set-variable! loc sym module value)
+ (make-sequence loc
+ (list (ensure-fluid! loc sym module)
+ (call-primitive loc 'fluid-set!
+ (make-module-ref loc module sym #t)
+ value))))
+
+
+; Process the bindings part of a let or let* expression; that is, check for
+; correctness and bring it to the form ((sym1 . val1) (sym2 . val2) ...).
+
+(define (process-let-bindings loc bindings)
+ (map (lambda (b)
+ (if (symbol? b)
+ (cons b 'nil)
+ (if (or (not (list? b))
+ (not (= (length b) 2)))
+ (report-error loc "expected symbol or list of 2 elements in let")
+ (if (not (symbol? (car b)))
+ (report-error loc "expected symbol in let")
+ (cons (car b) (cadr b))))))
+ bindings))
+
+
+; Split the argument list of a lambda expression into required, optional and
+; rest arguments and also check it is actually valid.
+
+(define (split-lambda-arguments loc args)
+ (let iterate ((tail args)
+ (mode 'required)
+ (required '())
+ (optional '()))
+ (cond
+
+ ((null? tail)
+ (values (reverse required) (reverse optional) #f))
+
+ ((and (eq? mode 'required)
+ (eq? (car tail) '&optional))
+ (iterate (cdr tail) 'optional required optional))
+
+ ((eq? (car tail) '&rest)
+ (if (or (null? (cdr tail))
+ (not (null? (cddr tail))))
+ (report-error loc "expected exactly one symbol after &rest")
+ (values (reverse required) (reverse optional) (cadr tail))))
+
+ (else
+ (if (not (symbol? (car tail)))
+ (report-error loc "expected symbol in argument list, got" (car tail))
+ (case mode
+ ((required) (iterate (cdr tail) mode
+ (cons (car tail) required) optional))
+ ((optional) (iterate (cdr tail) mode
+ required (cons (car tail) optional)))
+ ((else) (error "invalid mode in split-lambda-arguments"
mode))))))))
+
+
+; Compile a lambda expression. Things get a little complicated because TreeIL
+; does not allow optional arguments but only one rest argument, and also the
+; rest argument should be nil instead of '() for no values given. Because of
+; this, we have to do a little preprocessing to get everything done before the
+; real body is called.
+;
+; (lambda (a &optional b &rest c) body) should become:
+; (lambda (a_ . rest_)
+; (with-fluids* (list a b c) (list a_ nil nil)
+; (lambda ()
+; (if (not (null? rest_))
+; (begin
+; (fluid-set! b (car rest_))
+; (set! rest_ (cdr rest_))
+; (if (not (null? rest_))
+; (fluid-set! c rest_))))
+; body)))
+;
+; This is formulated quite imperatively, but I think in this case that is quite
+; clear and better than creating a lot of nested let's.
+
+(define (compile-lambda loc args body)
+ (call-with-values
+ (lambda ()
+ (split-lambda-arguments loc args))
+ (lambda (required optional rest)
+ ; FIXME: Ensure fluids there!
+ (let ((required-sym (map (lambda (sym) (gensym)) required))
+ (rest-sym (if (or rest (not (null? optional))) (gensym) '())))
+ (let ((real-args (append required-sym rest-sym)))
+ (make-lambda loc
+ real-args real-args '()
+ (call-primitive loc 'with-fluids*
+ (make-application loc (make-primitive-ref loc 'list)
+ (map (lambda (sym) (make-module-ref loc value-slot sym #t))
+ (append (append required optional)
+ (if rest (list rest) '()))))
+ (make-application loc (make-primitive-ref loc 'list)
+ (append (map (lambda (sym) (make-lexical-ref loc sym sym))
+ required-sym)
+ (map (lambda (sym) (nil-value loc))
+ (if (null? rest-sym)
+ optional
+ (append optional (list rest-sym))))))
+ (make-lambda loc '() '() '()
+ (make-sequence loc
+ (cons (process-optionals loc optional rest-sym)
+ (cons (process-rest loc rest rest-sym)
+ (map compile-expr body))))))))))))
+
+; Build the code to handle setting of optional arguments that are present
+; and updating the rest list.
+(define (process-optionals loc optional rest-sym)
+ (let iterate ((tail optional))
+ (if (null? tail)
+ (make-void loc)
+ (make-conditional loc
+ (call-primitive loc 'null? (make-lexical-ref loc rest-sym rest-sym))
+ (make-void loc)
+ (make-sequence loc
+ (list (set-variable! loc (car tail) value-slot
+ (call-primitive loc 'car
+ (make-lexical-ref loc rest-sym rest-sym)))
+ (make-lexical-set loc rest-sym rest-sym
+ (call-primitive loc 'cdr
+ (make-lexical-ref loc rest-sym rest-sym)))
+ (iterate (cdr tail))))))))
+
+; This builds the code to set the rest variable to nil if it is empty.
+(define (process-rest loc rest rest-sym)
+ (let ((rest-empty (call-primitive loc 'null?
+ (make-lexical-ref loc rest-sym rest-sym))))
+ (cond
+ (rest
+ (make-conditional loc rest-empty
+ (make-void loc)
+ (set-variable! loc rest value-slot
+ (make-lexical-ref loc rest-sym rest-sym))))
+ ((not (null? rest-sym))
+ (make-conditional loc rest-empty
+ (make-void loc)
+ (runtime-error loc "too many arguments and no rest argument")))
+ (else (make-void loc)))))
; Compile a symbol expression. This is a variable reference or maybe some
@@ -46,15 +245,12 @@
(define (compile-symbol loc sym)
(case sym
- ((nil)
- (nil-value loc))
+ ((nil) (nil-value loc))
- ((t)
- (make-const loc #t))
+ ((t) (t-value loc))
- ; FIXME: Use fluids.
(else
- (make-module-ref loc '(language elisp variables) sym #f))))
+ (reference-with-check loc sym value-slot))))
; Compile a pair-expression (that is, any structure-like construct).
@@ -78,7 +274,10 @@
(compile-expr ifclause)
(make-sequence loc (map compile-expr elses))))
- ; FIXME: Handle returning of condition value for empty clauses!
+ ; For (cond ...) forms, a special case is a (condition) clause without
+ ; body. In this case, the value of condition itself should be returned,
+ ; and thus is saved in a local variable for testing and returning, if it
+ ; is found true.
((cond . ,clauses) (guard (and-map (lambda (el)
(and (list? el) (not (null? el))))
clauses))
@@ -86,12 +285,20 @@
(if (null? tail)
(nil-value loc)
(let ((cur (car tail)))
- (make-conditional loc
- (compile-expr (car cur))
- (make-sequence loc (map compile-expr (cdr cur)))
- (iterate (cdr tail)))))))
+ (if (null? (cdr cur))
+ (let ((var (gensym)))
+ (make-let loc
+ '(condition) `(,var) `(,(compile-expr (car cur)))
+ (make-conditional loc
+ (make-lexical-ref loc 'condition var)
+ (make-lexical-ref loc 'condition var)
+ (iterate (cdr tail)))))
+ (make-conditional loc
+ (compile-expr (car cur))
+ (make-sequence loc (map compile-expr (cdr cur)))
+ (iterate (cdr tail))))))))
- ((and) (nil-value loc))
+ ((and) (t-value loc))
((and . ,expressions)
(let iterate ((tail expressions))
(if (null? (cdr tail))
@@ -101,11 +308,105 @@
(iterate (cdr tail))
(nil-value loc)))))
+ ((or . ,expressions)
+ (let iterate ((tail expressions))
+ (if (null? tail)
+ (nil-value loc)
+ (let ((var (gensym)))
+ (make-let loc
+ '(condition) `(,var) `(,(compile-expr (car tail)))
+ (make-conditional loc
+ (make-lexical-ref loc 'condition var)
+ (make-lexical-ref loc 'condition var)
+ (iterate (cdr tail))))))))
+
+ ; Build a set form for possibly multiple values. The code is not
formulated
+ ; tail recursive because it is clearer this way and large lists of symbol
+ ; expression pairs are very unlikely.
+ ((setq . ,args)
+ (make-sequence loc
+ (let iterate ((tail args))
+ (if (null? tail)
+ (list (make-void loc))
+ (let ((sym (car tail))
+ (tailtail (cdr tail)))
+ (if (not (symbol? sym))
+ (report-error loc "expected symbol in setq")
+ (if (null? tailtail)
+ (report-error loc "missing value for symbol in setq" sym)
+ (let* ((val (compile-expr (car tailtail)))
+ (op (set-variable! loc sym value-slot val)))
+ (cons op (iterate (cdr tailtail)))))))))))
+
+ ; Let is done with a single call to with-fluids* binding them locally to
new
+ ; values.
+ ((let ,bindings . ,body) (guard (and (list? bindings)
+ (list? body)
+ (not (null? bindings))
+ (not (null? body))))
+ (let ((bind (process-let-bindings loc bindings)))
+ (call-primitive loc 'with-fluids*
+ (make-application loc (make-primitive-ref loc 'list)
+ (map (lambda (el)
+ (make-module-ref loc value-slot (car el) #t))
+ bind))
+ (make-application loc (make-primitive-ref loc 'list)
+ (map (lambda (el)
+ (compile-expr (cdr el)))
+ bind))
+ (make-lambda loc '() '() '()
+ (make-sequence loc (map compile-expr body))))))
+
+ ; Let* is compiled to a cascaded set of with-fluid* for each binding in
turn
+ ; so that each one already sees the preceding bindings.
+ ((let* ,bindings . ,body) (guard (and (list? bindings)
+ (list? body)
+ (not (null? bindings))
+ (not (null? body))))
+ (let ((bind (process-let-bindings loc bindings)))
+ (let iterate ((tail bind))
+ (if (null? tail)
+ (make-sequence loc (map compile-expr body))
+ (call-primitive loc 'with-fluid*
+ (make-module-ref loc value-slot (caar tail) #t)
+ (compile-expr (cdar tail))
+ (make-lambda loc '() '() '() (iterate (cdr tail))))))))
+
+ ; A while construct is transformed into a tail-recursive loop like this:
+ ; (letrec ((iterate (lambda ()
+ ; (if condition
+ ; (begin body
+ ; (iterate))
+ ; %nil))))
+ ; (iterate))
+ ((while ,condition . ,body)
+ (let* ((itersym (gensym))
+ (compiled-body (map compile-expr body))
+ (iter-call (make-application loc
+ (make-lexical-ref loc 'iterate itersym)
+ (list)))
+ (full-body (make-sequence loc
+ (append compiled-body (list iter-call))))
+ (lambda-body (make-conditional loc
+ (compile-expr condition)
+ full-body
+ (nil-value loc)))
+ (iter-thunk (make-lambda loc '() '() '() lambda-body)))
+ (make-letrec loc '(iterate) (list itersym) (list iter-thunk)
+ iter-call)))
+
+ ; Either (lambda ...) or (function (lambda ...)) denotes a
lambda-expression
+ ; that should be compiled.
+ ((lambda ,args . ,body) (guard (not (null? body)))
+ (compile-lambda loc args body))
+ ((function (lambda ,args . ,body)) (guard (not (null? body)))
+ (compile-lambda loc args body))
+
(('quote ,val)
(make-const loc val))
(else
- (error "unrecognized elisp" expr))))
+ (report-error loc "unrecognized elisp" expr))))
; Compile a single expression to TreeIL.
diff --git a/module/system/vm/objcode.scm b/module/language/elisp/runtime.scm
similarity index 75%
copy from module/system/vm/objcode.scm
copy to module/language/elisp/runtime.scm
index ab6bb4b..871f3a2 100644
--- a/module/system/vm/objcode.scm
+++ b/module/language/elisp/runtime.scm
@@ -1,4 +1,4 @@
-;;; Guile VM object code
+;;; Guile Emac Lisp
;; Copyright (C) 2001 Free Software Foundation, Inc.
@@ -19,10 +19,10 @@
;;; Code:
-(define-module (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-objcode write-objcode
- word-size byte-order))
+(define-module (language elisp runtime)
+ #:export (void ensure-fluid! set-value! get-value unbind! bound?))
-(load-extension "libguile" "scm_init_objcodes")
+; This module provides runtime support for the Elisp front-end.
+
+; The reserved value to mean (when eq?) void.
+(define void (list 42))
diff --git a/module/system/vm/objcode.scm
b/module/language/elisp/runtime/function-slot.scm
similarity index 75%
copy from module/system/vm/objcode.scm
copy to module/language/elisp/runtime/function-slot.scm
index ab6bb4b..05aa6ee 100644
--- a/module/system/vm/objcode.scm
+++ b/module/language/elisp/runtime/function-slot.scm
@@ -1,4 +1,4 @@
-;;; Guile VM object code
+;;; Guile Emac Lisp
;; Copyright (C) 2001 Free Software Foundation, Inc.
@@ -19,10 +19,6 @@
;;; Code:
-(define-module (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-objcode write-objcode
- word-size byte-order))
+(define-module (language elisp runtime value-slot))
-(load-extension "libguile" "scm_init_objcodes")
+; This module contains the function-slots of elisp symbols.
diff --git a/module/system/vm/objcode.scm
b/module/language/elisp/runtime/value-slot.scm
similarity index 75%
copy from module/system/vm/objcode.scm
copy to module/language/elisp/runtime/value-slot.scm
index ab6bb4b..201813a 100644
--- a/module/system/vm/objcode.scm
+++ b/module/language/elisp/runtime/value-slot.scm
@@ -1,4 +1,4 @@
-;;; Guile VM object code
+;;; Guile Emac Lisp
;; Copyright (C) 2001 Free Software Foundation, Inc.
@@ -19,10 +19,6 @@
;;; Code:
-(define-module (system vm objcode)
- #:export (objcode? objcode-meta
- bytecode->objcode objcode->bytecode
- load-objcode write-objcode
- word-size byte-order))
+(define-module (language elisp runtime value-slot))
-(load-extension "libguile" "scm_init_objcodes")
+; This module contains the value-slots of elisp symbols.
diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test
index 57e2f9b..4a9476a 100644
--- a/test-suite/tests/numbers.test
+++ b/test-suite/tests/numbers.test
@@ -1365,7 +1365,14 @@
("address@hidden" 1.0) ("address@hidden" 1.0)
("address@hidden" 1.0)
("2+3i" ,(+ 2 (* 3 +i))) ("4-5i" ,(- 4 (* 5 +i)))
("1+i" 1+1i) ("1-i" 1-1i) ("+1i" 0+1i) ("-1i" 0-1i)
- ("+i" +1i) ("-i" -1i)))
+ ("+i" +1i) ("-i" -1i)
+ ("1.0+.1i" 1.0+0.1i)
+ ("1.0-.1i" 1.0-0.1i)
+ (".1+.0i" 0.1)
+ ("1.+.0i" 1.0)
+ (".1+.1i" 0.1+0.1i)
+ ("1e1+.1i" 10+0.1i)
+ ))
#t)
(pass-if-exception "exponent too big"
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, elisp, updated. release_1-9-0-47-g50abfe7,
Daniel Kraft <=