From eb6c635af6e9c6e2df3be0e06c8fe84b5b728ad1 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 8 Aug 2003 23:05:30 +0000 Subject: [PATCH 001/109] * tests/srcprop.test: New file. * Makefile.am (SCM_TESTS): Add it. --- test-suite/Makefile.am | 1 + 1 file changed, 1 insertion(+) diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 0318e5d67..4a34bd868 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -28,6 +28,7 @@ SCM_TESTS = tests/alist.test \ tests/r4rs.test \ tests/reader.test \ tests/regexp.test \ + tests/srcprop.test \ tests/srfi-1.test \ tests/srfi-6.test \ tests/srfi-10.test \ From 3bcdda6a02faa81dc220e5066483f21a9155c071 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 8 Aug 2003 23:07:07 +0000 Subject: [PATCH 002/109] *** empty log message *** --- test-suite/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 5f2f6d070..cf40aa911 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-08-09 Kevin Ryde + + * tests/srcprop.test: New file. + * Makefile.am (SCM_TESTS): Add it. + 2003-07-29 Kevin Ryde * tests/srfi-1.test (concatenate, concatenate!): New tests. From ba6a6d553525d68b408d70405f6fe0246152dd52 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 8 Aug 2003 23:28:11 +0000 Subject: [PATCH 003/109] Add source-properties versus set-source-properties! fix. --- NEWS | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NEWS b/NEWS index ef046994f..d3d433a0e 100644 --- a/NEWS +++ b/NEWS @@ -461,6 +461,11 @@ chapter in the reference manual. There is no replacement for undefine. +** source-properties and set-source-properties! fix + +Properties set with set-source-properties! can now be read back +correctly with source-properties. + ** SRFI-1 delete equality argument order fixed. In the srfi-1 module delete and delete!, the order of the arguments to From 4d332f190ce433a2e4237f05de8467b90cedb2a5 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 10 Aug 2003 13:19:54 +0000 Subject: [PATCH 004/109] * tests/numbers.test: Eliminated misuses of expect-fail. It should only be used in cases, where guile has a known bug. It should not be used in cases where an expression is expected to return #f as its correct result. --- test-suite/ChangeLog | 7 ++ test-suite/tests/numbers.test | 176 +++++++++++++++++----------------- 2 files changed, 95 insertions(+), 88 deletions(-) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index cf40aa911..59584f40a 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2003-08-10 Dirk Herrmann + + * tests/numbers.test: Eliminated misuses of expect-fail. It + should only be used in cases, where guile has a known bug. It + should not be used in cases where an expression is expected to + return #f as its correct result. + 2003-08-09 Kevin Ryde * tests/srcprop.test: New file. diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index c889ea106..3fe309476 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -77,13 +77,13 @@ (pass-if (documented? odd?)) (pass-if (odd? 1)) (pass-if (odd? -1)) - (expect-fail (odd? 0)) - (expect-fail (odd? 2)) - (expect-fail (odd? -2)) + (pass-if (not (odd? 0))) + (pass-if (not (odd? 2))) + (pass-if (not (odd? -2))) (pass-if (odd? (+ (* 2 fixnum-max) 1))) - (expect-fail (odd? (* 2 fixnum-max))) + (pass-if (not (odd? (* 2 fixnum-max)))) (pass-if (odd? (- (* 2 fixnum-min) 1))) - (expect-fail (odd? (* 2 fixnum-min)))) + (pass-if (not (odd? (* 2 fixnum-min))))) ;;; ;;; even? @@ -94,11 +94,11 @@ (pass-if (even? 2)) (pass-if (even? -2)) (pass-if (even? 0)) - (expect-fail (even? 1)) - (expect-fail (even? -1)) - (expect-fail (even? (+ (* 2 fixnum-max) 1))) + (pass-if (not (even? 1))) + (pass-if (not (even? -1))) + (pass-if (not (even? (+ (* 2 fixnum-max) 1)))) (pass-if (even? (* 2 fixnum-max))) - (expect-fail (even? (- (* 2 fixnum-min) 1))) + (pass-if (not (even? (- (* 2 fixnum-min) 1)))) (pass-if (even? (* 2 fixnum-min)))) ;;; @@ -111,10 +111,10 @@ ;; FIXME: what are the expected behaviors? ;; (pass-if (inf? (/ 1.0 0.0)) ;; (pass-if (inf? (/ 1 0.0)) - (expect-fail (inf? 0)) - (expect-fail (inf? 42.0)) - (expect-fail (inf? (+ fixnum-max 1))) - (expect-fail (inf? (- fixnum-min 1)))) + (pass-if (not (inf? 0))) + (pass-if (not (inf? 42.0))) + (pass-if (not (inf? (+ fixnum-max 1)))) + (pass-if (not (inf? (- fixnum-min 1))))) ;;; ;;; nan? and nan @@ -124,10 +124,10 @@ (pass-if (documented? nan?)) (pass-if (nan? (nan))) ;; FIXME: other ways we should be able to generate NaN? - (expect-fail (nan? 0)) - (expect-fail (nan? 42.0)) - (expect-fail (nan? (+ fixnum-max 1))) - (expect-fail (nan? (- fixnum-min 1)))) + (pass-if (not (nan? 0))) + (pass-if (not (nan? 42.0))) + (pass-if (not (nan? (+ fixnum-max 1)))) + (pass-if (not (nan? (- fixnum-min 1))))) ;;; ;;; abs @@ -1031,13 +1031,13 @@ (pass-if (number? (+ 1 fixnum-max))) (pass-if (number? (- 1 fixnum-min))) (pass-if (number? 3+4i)) - (expect-fail (number? #\a)) - (expect-fail (number? "a")) - (expect-fail (number? (make-vector 0))) - (expect-fail (number? (cons 1 2))) - (expect-fail (number? #t)) - (expect-fail (number? (lambda () #t))) - (expect-fail (number? (current-input-port)))) + (pass-if (not (number? #\a))) + (pass-if (not (number? "a"))) + (pass-if (not (number? (make-vector 0)))) + (pass-if (not (number? (cons 1 2)))) + (pass-if (not (number? #t))) + (pass-if (not (number? (lambda () #t)))) + (pass-if (not (number? (current-input-port))))) ;;; ;;; complex? @@ -1052,13 +1052,13 @@ (pass-if (complex? (- 1 fixnum-min))) (pass-if (complex? 1.3)) (pass-if (complex? 3+4i)) - (expect-fail (complex? #\a)) - (expect-fail (complex? "a")) - (expect-fail (complex? (make-vector 0))) - (expect-fail (complex? (cons 1 2))) - (expect-fail (complex? #t)) - (expect-fail (complex? (lambda () #t))) - (expect-fail (complex? (current-input-port)))) + (pass-if (not (complex? #\a))) + (pass-if (not (complex? "a"))) + (pass-if (not (complex? (make-vector 0)))) + (pass-if (not (complex? (cons 1 2)))) + (pass-if (not (complex? #t))) + (pass-if (not (complex? (lambda () #t)))) + (pass-if (not (complex? (current-input-port))))) ;;; ;;; real? @@ -1072,14 +1072,14 @@ (pass-if (real? (+ 1 fixnum-max))) (pass-if (real? (- 1 fixnum-min))) (pass-if (real? 1.3)) - (expect-fail (real? 3+4i)) - (expect-fail (real? #\a)) - (expect-fail (real? "a")) - (expect-fail (real? (make-vector 0))) - (expect-fail (real? (cons 1 2))) - (expect-fail (real? #t)) - (expect-fail (real? (lambda () #t))) - (expect-fail (real? (current-input-port)))) + (pass-if (not (real? 3+4i))) + (pass-if (not (real? #\a))) + (pass-if (not (real? "a"))) + (pass-if (not (real? (make-vector 0)))) + (pass-if (not (real? (cons 1 2)))) + (pass-if (not (real? #t))) + (pass-if (not (real? (lambda () #t)))) + (pass-if (not (real? (current-input-port))))) ;;; ;;; rational? (same as real? right now) @@ -1093,14 +1093,14 @@ (pass-if (rational? (+ 1 fixnum-max))) (pass-if (rational? (- 1 fixnum-min))) (pass-if (rational? 1.3)) - (expect-fail (rational? 3+4i)) - (expect-fail (rational? #\a)) - (expect-fail (rational? "a")) - (expect-fail (rational? (make-vector 0))) - (expect-fail (rational? (cons 1 2))) - (expect-fail (rational? #t)) - (expect-fail (rational? (lambda () #t))) - (expect-fail (rational? (current-input-port)))) + (pass-if (not (rational? 3+4i))) + (pass-if (not (rational? #\a))) + (pass-if (not (rational? "a"))) + (pass-if (not (rational? (make-vector 0)))) + (pass-if (not (rational? (cons 1 2)))) + (pass-if (not (rational? #t))) + (pass-if (not (rational? (lambda () #t)))) + (pass-if (not (rational? (current-input-port))))) ;;; ;;; integer? @@ -1115,15 +1115,15 @@ (pass-if (integer? (- 1 fixnum-min))) (pass-if (and (= 3+0i (round 3+0i)) (integer? 3+0i))) (pass-if (and (= 1.0 (round 1.0)) (integer? 1.0))) - (expect-fail (integer? 1.3)) - (expect-fail (integer? 3+4i)) - (expect-fail (integer? #\a)) - (expect-fail (integer? "a")) - (expect-fail (integer? (make-vector 0))) - (expect-fail (integer? (cons 1 2))) - (expect-fail (integer? #t)) - (expect-fail (integer? (lambda () #t))) - (expect-fail (integer? (current-input-port)))) + (pass-if (not (integer? 1.3))) + (pass-if (not (integer? 3+4i))) + (pass-if (not (integer? #\a))) + (pass-if (not (integer? "a"))) + (pass-if (not (integer? (make-vector 0)))) + (pass-if (not (integer? (cons 1 2)))) + (pass-if (not (integer? #t))) + (pass-if (not (integer? (lambda () #t)))) + (pass-if (not (integer? (current-input-port))))) ;;; ;;; inexact? @@ -1131,20 +1131,20 @@ (with-test-prefix "inexact?" (pass-if (documented? inexact?)) - (expect-fail (inexact? 0)) - (expect-fail (inexact? 7)) - (expect-fail (inexact? -7)) - (expect-fail (inexact? (+ 1 fixnum-max))) - (expect-fail (inexact? (- 1 fixnum-min))) + (pass-if (not (inexact? 0))) + (pass-if (not (inexact? 7))) + (pass-if (not (inexact? -7))) + (pass-if (not (inexact? (+ 1 fixnum-max)))) + (pass-if (not (inexact? (- 1 fixnum-min)))) (pass-if (inexact? 1.3)) (pass-if (inexact? 3.1+4.2i)) - (expect-fail (inexact? #\a)) - (expect-fail (inexact? "a")) - (expect-fail (inexact? (make-vector 0))) - (expect-fail (inexact? (cons 1 2))) - (expect-fail (inexact? #t)) - (expect-fail (inexact? (lambda () #t))) - (expect-fail (inexact? (current-input-port)))) + (pass-if (not (inexact? #\a))) + (pass-if (not (inexact? "a"))) + (pass-if (not (inexact? (make-vector 0)))) + (pass-if (not (inexact? (cons 1 2)))) + (pass-if (not (inexact? #t))) + (pass-if (not (inexact? (lambda () #t)))) + (pass-if (not (inexact? (current-input-port))))) ;;; ;;; = @@ -1157,12 +1157,12 @@ (pass-if (= -7 -7)) (pass-if (= (+ 1 fixnum-max) (+ 1 fixnum-max))) (pass-if (= (- 1 fixnum-min) (- 1 fixnum-min))) - (expect-fail (= 0 1)) - (expect-fail (= fixnum-max (+ 1 fixnum-max))) - (expect-fail (= (+ 1 fixnum-max) fixnum-max)) - (expect-fail (= fixnum-min (- fixnum-min 1))) - (expect-fail (= (- fixnum-min 1) fixnum-min)) - (expect-fail (= (+ fixnum-max 1) (- fixnum-min 1))) + (pass-if (not (= 0 1))) + (pass-if (not (= fixnum-max (+ 1 fixnum-max)))) + (pass-if (not (= (+ 1 fixnum-max) fixnum-max))) + (pass-if (not (= fixnum-min (- fixnum-min 1)))) + (pass-if (not (= (- fixnum-min 1) fixnum-min))) + (pass-if (not (= (+ fixnum-max 1) (- fixnum-min 1)))) (pass-if (not (= (ash 1 256) +inf.0))) (pass-if (not (= +inf.0 (ash 1 256)))) @@ -1606,12 +1606,12 @@ (with-test-prefix "zero?" (expect-fail (documented? zero?)) (pass-if (zero? 0)) - (expect-fail (zero? 7)) - (expect-fail (zero? -7)) - (expect-fail (zero? (+ 1 fixnum-max))) - (expect-fail (zero? (- 1 fixnum-min))) - (expect-fail (zero? 1.3)) - (expect-fail (zero? 3.1+4.2i))) + (pass-if (not (zero? 7))) + (pass-if (not (zero? -7))) + (pass-if (not (zero? (+ 1 fixnum-max)))) + (pass-if (not (zero? (- 1 fixnum-min)))) + (pass-if (not (zero? 1.3))) + (pass-if (not (zero? 3.1+4.2i)))) ;;; ;;; positive? @@ -1622,10 +1622,10 @@ (pass-if (positive? 1)) (pass-if (positive? (+ fixnum-max 1))) (pass-if (positive? 1.3)) - (expect-fail (positive? 0)) - (expect-fail (positive? -1)) - (expect-fail (positive? (- fixnum-min 1))) - (expect-fail (positive? -1.3))) + (pass-if (not (positive? 0))) + (pass-if (not (positive? -1))) + (pass-if (not (positive? (- fixnum-min 1)))) + (pass-if (not (positive? -1.3)))) ;;; ;;; negative? @@ -1633,10 +1633,10 @@ (with-test-prefix "negative?" (expect-fail (documented? negative?)) - (expect-fail (negative? 1)) - (expect-fail (negative? (+ fixnum-max 1))) - (expect-fail (negative? 1.3)) - (expect-fail (negative? 0)) + (pass-if (not (negative? 1))) + (pass-if (not (negative? (+ fixnum-max 1)))) + (pass-if (not (negative? 1.3))) + (pass-if (not (negative? 0))) (pass-if (negative? -1)) (pass-if (negative? (- fixnum-min 1))) (pass-if (negative? -1.3))) From 6a4d17af96ea0a73c4fd77405920d75a8cc4d629 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 20:23:35 +0000 Subject: [PATCH 005/109] (getenv): Use for prototype. --- libguile/simpos.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index d124d5bf4..fb0a13271 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -22,6 +22,7 @@ #endif #include +#include /* for getenv */ #include "libguile/_scm.h" @@ -74,7 +75,6 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, #undef FUNC_NAME #endif /* HAVE_SYSTEM */ -extern char *getenv(); SCM_DEFINE (scm_getenv, "getenv", 1, 0, 0, (SCM nam), "Looks up the string @var{name} in the current environment. The return\n" From 34b6177b15201248a63305f835275c672bcb0f25 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 20:24:52 +0000 Subject: [PATCH 006/109] (scm_system): In docstring, refer to status:exit-val rather than "functions above". --- libguile/simpos.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index fb0a13271..8c4dda542 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -49,8 +49,8 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, "Execute @var{cmd} using the operating system's \"command\n" "processor\". Under Unix this is usually the default shell\n" "@code{sh}. The value returned is @var{cmd}'s exit status as\n" - "returned by @code{waitpid}, which can be interpreted using the\n" - "functions above.\n" + "returned by @code{waitpid}, which can be interpreted using\n" + "@code{status:exit-val} and friends.\n" "\n" "If @code{system} is called without arguments, return a boolean\n" "indicating whether the command processor is available.") From aca3618f817e4890b26c8389a2be01115a3a6af2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:08:34 +0000 Subject: [PATCH 007/109] (scm_remember_upto_here_1, scm_remember_upto_here_2) [__GNUC__]: Use volatile asm macros rather than a function call. --- libguile/gc.h | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/libguile/gc.h b/libguile/gc.h index 1dca8c2c0..f588b3ca0 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -341,6 +341,26 @@ SCM_API char *scm_gc_strndup (const char *str, size_t n, const char *what); SCM_API void scm_remember_upto_here_1 (SCM obj); SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2); SCM_API void scm_remember_upto_here (SCM obj1, ...); + +/* In GCC we can force a reference to an SCM with a little do-nothing asm, + avoiding the code size and slowdown of an actual function call. + __volatile__ ensures nothing will be moved across the reference, and that + it won't be optimized away (or rather only if proved unreachable). + Unfortunately there doesn't seem to be any way to do the varargs + scm_remember_upto_here similarly. */ + +#ifdef __GNUC__ +#define scm_remember_upto_here_1(x) \ + do { \ + __asm__ __volatile__ ("" : : "g" (x)); \ + } while (0) +#define scm_remember_upto_here_2(x, y) \ + do { \ + scm_remember_upto_here_1 (x); \ + scm_remember_upto_here_1 (y); \ + } while (0) +#endif + SCM_API SCM scm_return_first (SCM elt, ...); SCM_API int scm_return_first_int (int x, ...); SCM_API SCM scm_permanent_object (SCM obj); From 9e1569bd0d1948454135401274a000fb7b483989 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:09:10 +0000 Subject: [PATCH 008/109] (scm_remember_upto_here_1, scm_remember_upto_here_2): Undefine macros while defining functions. --- libguile/gc.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/libguile/gc.c b/libguile/gc.c index 04f1a2efd..50032bdad 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -656,6 +656,12 @@ scm_igc (const char *what) * scm_remember_upto_here_1 (str); // str will be alive up to this point. */ +/* Remove any macro versions of these while defining the functions. + Functions are always included in the library, for upward binary + compatibility and in case combinations of GCC and non-GCC are used. */ +#undef scm_remember_upto_here_1 +#undef scm_remember_upto_here_2 + void scm_remember_upto_here_1 (SCM obj SCM_UNUSED) { From 88a63bfc106fd23a3f6800ad184c91e1402e5a6a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:18:23 +0000 Subject: [PATCH 009/109] (open-process): Close input-fdes, output-fdes and error-fdes after duping them to 0, 1 and 2. --- ice-9/popen.scm | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/ice-9/popen.scm b/ice-9/popen.scm index bacfccf03..1e6f30b36 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -1,6 +1,6 @@ ;; popen emulation, for non-stdio based ports. -;;;; Copyright (C) 1998, 1999, 2000, 2001 Free Software Foundation, Inc. +;;;; Copyright (C) 1998, 1999, 2000, 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 @@ -90,14 +90,18 @@ (set! output-fdes (dup->fdes 0))) (if (= error-fdes 0) (set! error-fdes (dup->fdes 0))) - (dup2 input-fdes 0))) + (dup2 input-fdes 0) + (close-fdes input-fdes))) (cond ((not (= output-fdes 1)) (if (= error-fdes 1) (set! error-fdes (dup->fdes 1))) - (dup2 output-fdes 1))) + (dup2 output-fdes 1) + (close-fdes output-fdes))) - (dup2 error-fdes 2) + (cond ((not (= error-fdes 2)) + (dup2 error-fdes 2) + (close-fdes error-fdes))) (apply execlp prog prog args))) From 773abfbb81fa5522c9abfdfbf7bc177fca88ae82 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:38:21 +0000 Subject: [PATCH 010/109] (while): Rewrite, continue as proper escape, break without return value, break and continue new for each while form, don't depend on bindings in expansion environment. --- ice-9/boot-9.scm | 32 ++++++++++++++++++++------------ 1 file changed, 20 insertions(+), 12 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 4e09c9063..93f3bf365 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2491,18 +2491,6 @@ (loop (1- count) (cons count result))))) -;;; {While} -;;; -;;; with `continue' and `break'. -;;; - -(defmacro while (cond . body) - `(letrec ((continue (lambda () (or (not ,cond) (begin (begin ,@ body) (continue))))) - (break (lambda val (apply throw 'break val)))) - (catch 'break - (lambda () (continue)) - (lambda v (cadr v))))) - ;;; {collect} ;;; ;;; Similar to `begin' but returns a list of the results of all constituent @@ -2560,6 +2548,26 @@ (else (error "define-syntax-macro can only be used at the top level"))))) +;;; {While} +;;; +;;; with `continue' and `break'. +;;; + +;; The inner `do' loop avoids re-establishing a catch every iteration, +;; that's only necessary if continue is actually used. +;; +(define-macro (while cond . body) + (let ((key (make-symbol "while-key"))) + `(,do ((break ,(lambda () (throw key #t))) + (continue ,(lambda () (throw key #f)))) + ((,catch (,quote ,key) + (,lambda () + (,do () + ((,not ,cond)) + ,@body) + #t) + ,(lambda (key arg) arg)))))) + ;;; {Module System Macros} ;;; From 2798ba71cdbd033bb44c962c9e5b8450e7799e79 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:39:30 +0000 Subject: [PATCH 011/109] (while): New tests. --- test-suite/tests/syntax.test | 168 +++++++++++++++++++++++++++++++++++ 1 file changed, 168 insertions(+) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index a4246ef7f..3317f78bd 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -550,3 +550,171 @@ exception:missing/extra-expr (eval '(quote a b) (interaction-environment))))) + +(with-test-prefix "while" + + (define (unreachable) + (error "unreachable code has been reached!")) + + ;; an environment with no bindings at all + (define empty-environment + (make-module 1)) + + ;; Return a new procedure COND which when called (COND) will return #t the + ;; first N times, then #f, then any further call is an error. N=0 is + ;; allowed, in which case #f is returned by the first call. + (define (make-iterations-cond n) + (lambda () + (cond ((not n) + (error "oops, condition re-tested after giving false")) + ((= 0 n) + (set! n #f) + #f) + (else + (set! n (1- n)) + #t)))) + + + (pass-if-exception "too few args" exception:wrong-num-args + (while)) + + (with-test-prefix "empty body" + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n))) + (while (cond))) + #t))) + + (pass-if "initially false" + (while #f + (unreachable)) + #t) + + (with-test-prefix "in empty environment" + + (pass-if "empty body" + (eval `(,while #f) + empty-environment) + #t) + + (pass-if "initially false" + (eval `(,while #f + #f) + empty-environment) + #t) + + (pass-if "iterating" + (let ((cond (make-iterations-cond 3))) + (eval `(,while (,cond) + 123 456) + empty-environment)) + #t)) + + (with-test-prefix "iterations" + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n)) + (i 0)) + (while (cond) + (set! i (1+ i))) + (= i n))))) + + (with-test-prefix "break" + + (pass-if-exception "too many args" exception:wrong-num-args + (while #t + (break 1))) + + (with-test-prefix "from cond" + (pass-if "first" + (while (begin + (break) + (unreachable)) + (unreachable)) + #t) + + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n)) + (i 0)) + (while (if (cond) + #t + (begin + (break) + (unreachable))) + (set! i (1+ i))) + (= i n))))) + + (with-test-prefix "from body" + (pass-if "first" + (while #t + (break) + (unreachable)) + #t) + + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n)) + (i 0)) + (while #t + (if (not (cond)) + (begin + (break) + (unreachable))) + (set! i (1+ i))) + (= i n))))) + + (pass-if "from nested" + (while #t + (let ((outer-break break)) + (while #t + (outer-break) + (unreachable))) + (unreachable)) + #t)) + + (with-test-prefix "continue" + + (pass-if-exception "too many args" exception:wrong-num-args + (while #t + (continue 1))) + + (with-test-prefix "from cond" + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n)) + (i 0)) + (while (if (cond) + (begin + (set! i (1+ i)) + (continue) + (unreachable)) + #f) + (unreachable)) + (= i n))))) + + (with-test-prefix "from body" + (do ((n 0 (1+ n))) + ((> n 5)) + (pass-if n + (let ((cond (make-iterations-cond n)) + (i 0)) + (while (cond) + (set! i (1+ i)) + (continue) + (unreachable)) + (= i n))))) + + (pass-if "from nested" + (let ((cond (make-iterations-cond 3))) + (while (cond) + (let ((outer-continue continue)) + (while #t + (outer-continue) + (unreachable))))) + #t))) From 9f977dd883c9a873d91044c6702924002a5a3512 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:39:56 +0000 Subject: [PATCH 012/109] Add a copyright year. --- test-suite/tests/syntax.test | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index 3317f78bd..bbdda2735 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -1,6 +1,6 @@ ;;;; syntax.test --- test suite for Guile's syntactic forms -*- 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 From d97f9b42308e8ee5a469d29d690b7bc5880aff44 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:43:34 +0000 Subject: [PATCH 013/109] *** empty log message *** --- ice-9/ChangeLog | 9 +++++++++ libguile/ChangeLog | 11 +++++++++++ test-suite/ChangeLog | 4 ++++ 3 files changed, 24 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index aed8e2158..5ce4226db 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,12 @@ +2003-08-14 Kevin Ryde + + * boot-9.scm (while): Rewrite, continue as proper escape, break + without return value, break and continue new for each while form, + don't depend on bindings in expansion environment. + + * popen.scm (open-process): Close input-fdes, output-fdes and + error-fdes after duping them to 0, 1 and 2. + 2003-06-19 Kevin Ryde * threads.scm (parallel): For no forms, use `(values)' not `(begin)'. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3edbe4b8f..a135d4ec1 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,14 @@ +2003-08-14 Kevin Ryde + + * gc.h (scm_remember_upto_here_1, scm_remember_upto_here_2) + [__GNUC__]: Use volatile asm macros rather than a function call. + * gc.c (scm_remember_upto_here_1, scm_remember_upto_here_2): Undefine + macros while defining functions. + + * simpos.c (getenv): Use for prototype. + (scm_system): In docstring, refer to status:exit-val rather than + "functions above". + 2003-08-09 Kevin Ryde * srcprop.c (scm_source_properties): Return plist from hash if it's a diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 59584f40a..de576426f 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-08-14 Kevin Ryde + + * tests/syntax.test (while): New tests. + 2003-08-10 Dirk Herrmann * tests/numbers.test: Eliminated misuses of expect-fail. It From bbdbcf35ae9483e2267bba85f7b28ff5e37e0356 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:48:27 +0000 Subject: [PATCH 014/109] (while do): Update `while' for code rewrite, in particular describe break and continue. --- doc/ref/scheme-control.texi | 38 +++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index 38da00412..8a3884a62 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -197,10 +197,40 @@ corresponding variable is not changed during looping. @end deffn @deffn syntax while cond body @dots{} -Evaluate all expressions in @var{body} in order, as long as @var{cond} -evaluates to a true value. The @var{cond} expression is tested before -every iteration, so that the body is not evaluated at all if @var{cond} -is @code{#f} right from the start. +Run a loop executing the @var{body} forms while @var{cond} is true. +@var{cond} is tested at the start of each iteration, so if it's +@code{#f} the first time then @var{body} is not executed at all. The +return value is unspecified. + +Within @code{while}, two extra bindings are provided, they can be used +from both @var{cond} and @var{body}. + +@deffn {Scheme Procedure} break +Break out of the @code{while} form. +@end deffn + +@deffn {Scheme Procedure} continue +Abandon the current iteration, go back to the start and test +@var{cond} again, etc. +@end deffn + +Each @code{while} form gets its own @code{break} and @code{continue} +procedures, operating on that @code{while}. This means when loops are +nested the outer @code{break} can be used to escape all the way out. +For example, + +@example +(while (test1) + (let ((outer-break break)) + (while (test2) + (if (something) + (outer-break #f)) + ...))) +@end example + +Note that each @code{break} and @code{continue} procedure can only be +used within the dynamic extent of its @code{while}. Outside the +@code{while} their behaviour is unspecified. @end deffn @cindex named let From 78c2d49cdef9aa713b7b7ea9297160a8d437cf10 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 12 Aug 2003 21:48:57 +0000 Subject: [PATCH 015/109] *** empty log message *** --- doc/ref/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 369569d4f..d6b8312a4 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,8 @@ +2003-08-14 Kevin Ryde + + * scheme-control.texi (while do): Update `while' for code rewrite, in + particular describe break and continue. + 2003-08-09 Kevin Ryde * scheme-memory.texi (Memory Blocks): Add index entries for deprecated From ac5fa6d1bef480f3235a0731008539c89c807691 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 17 Aug 2003 00:28:51 +0000 Subject: [PATCH 016/109] (Hash Table Reference): Collect up groups of functions to avoid duplication. Revise notes on hashx functions and on vector implementation. In make-hash-table, size is now optional. Add hash-map and hash-for-each. --- doc/ref/scheme-compound.texi | 327 ++++++++++++++--------------------- 1 file changed, 133 insertions(+), 194 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index b8ab32ecb..447d96249 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -2245,238 +2245,177 @@ a hash table, but @code{hash-fold} can be used for doing exactly that. @node Hash Table Reference @subsubsection Hash Table Reference -Like the association list functions, the hash table functions come -in several varieties: @code{hashq}, @code{hashv}, and @code{hash}. -The @code{hashq} functions use @code{eq?} to determine whether two -keys match. The @code{hashv} functions use @code{eqv?}, and the -@code{hash} functions use @code{equal?}. +@c FIXME: Describe in broad terms what happens for resizing, and what +@c the initial size means for this. -In each of the functions that follow, the @var{table} argument -must be a vector. The @var{key} and @var{value} arguments may be -any Scheme object. +Like the association list functions, the hash table functions come in +several varieties, according to the equality test used for the keys. +Plain @code{hash-} functions use @code{equal?}, @code{hashq-} +functions use @code{eq?}, @code{hashv-} functions use @code{eqv?}, and +the @code{hashx-} functions use an application supplied test (for +instance to implement case insensitive strings). -@deffn {Scheme Procedure} make-hash-table size -Create a new hash table of @var{size} slots. Note that the number of -slots does not limit the size of the table, it just tells how large -the underlying vector will be. The @var{size} should be similar to -the expected number of elements which will be added to the table, but -they need not match. For good performance, it might be a good idea to -use a prime number as the @var{size}. -@end deffn +A single @code{make-hash-table} creates a hash table suitable for use +with any set of functions, but it's imperative that just one set is +then used consistently, or results will be unpredictable. -@deffn {Scheme Procedure} hashq-ref table key [dflt] -@deffnx {C Function} scm_hashq_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{eq?} for equality testing. -@end deffn +@sp 1 +Hash tables are implemented as a vector indexed by an integer formed +from the key, with an association list of key/value pairs for each +bucket in case distinct keys hash together. Direct access to the +pairs in those lists is provided by the @code{-handle-} functions. -@deffn {Scheme Procedure} hashv-ref table key [dflt] -@deffnx {C Function} scm_hashv_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{eqv?} for equality testing. +For the @code{hashx-} ``extended'' routines, an application supplies a +@var{hash} function producing an integer index (like @code{hashq} etc +below), and an @var{assoc} alist search function (like @code{assq} +etc, @xref{Retrieving Alist Entries}.). The aim in the @var{hash} +function is to have different keys spread out across the vector, so +the bucket lists don't become long, but the exact values generated are +otherwise arbitrary. + +@sp 1 +@deffn {Scheme Procedure} make-hash-table [size] +Create a new hash table, with an optional initial vector @var{size}. + +@var{size} doesn't limit the entries in the table, merely gives a +starting size for the internal vector. A prime number bigger than the +expected number of entries would be a good choice. @end deffn @deffn {Scheme Procedure} hash-ref table key [dflt] +@deffnx {Scheme Procedure} hashq-ref table key [dflt] +@deffnx {Scheme Procedure} hashv-ref table key [dflt] +@deffnx {Scheme Procedure} hashx-ref hash assoc table key [dflt] @deffnx {C Function} scm_hash_ref (table, key, dflt) -Look up @var{key} in the hash table @var{table}, and return the -value (if any) associated with it. If @var{key} is not found, -return @var{default} (or @code{#f} if no @var{default} argument -is supplied). Uses @code{equal?} for equality testing. -@end deffn - -@deffn {Scheme Procedure} hashq-set! table key val -@deffnx {C Function} scm_hashq_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{eq?} for equality testing. -@end deffn - -@deffn {Scheme Procedure} hashv-set! table key val -@deffnx {C Function} scm_hashv_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{eqv?} for equality testing. +@deffnx {C Function} scm_hashq_ref (table, key, dflt) +@deffnx {C Function} scm_hashv_ref (table, key, dflt) +@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) +Lookup @var{key} in the given hash @var{table}, and return the +associated value. If @var{key} is not found, return @var{dflt}, or +@code{#f} if @var{dflt} is not given. (For the C functions, +@var{dflt} must be given.) @end deffn @deffn {Scheme Procedure} hash-set! table key val +@deffnx {Scheme Procedure} hashq-set! table key val +@deffnx {Scheme Procedure} hashv-set! table key val +@deffnx {Scheme Procedure} hashx-set! hash assoc table key val @deffnx {C Function} scm_hash_set_x (table, key, val) -Find the entry in @var{table} associated with @var{key}, and -store @var{value} there. Uses @code{equal?} for equality -testing. -@end deffn - -@deffn {Scheme Procedure} hashq-remove! table key -@deffnx {C Function} scm_hashq_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eq?} for equality tests. -@end deffn - -@deffn {Scheme Procedure} hashv-remove! table key -@deffnx {C Function} scm_hashv_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{eqv?} for equality tests. +@deffnx {C Function} scm_hashq_set_x (table, key, val) +@deffnx {C Function} scm_hashv_set_x (table, key, val) +@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) +Associate @var{val} with @var{key} in the given hash @var{table}. If +@var{key} is already present then it's associated value is changed. +If it's not present then a new entry is created. @end deffn @deffn {Scheme Procedure} hash-remove! table key +@deffnx {Scheme Procedure} hashq-remove! table key +@deffnx {Scheme Procedure} hashv-remove! table key @deffnx {C Function} scm_hash_remove_x (table, key) -Remove @var{key} (and any value associated with it) from -@var{table}. Uses @code{equal?} for equality tests. -@end deffn - -The standard hash table functions may be too limited for some -applications. For example, you may want a hash table to store -strings in a case-insensitive manner, so that references to keys -named ``foobar'', ``FOOBAR'' and ``FooBaR'' will all yield the -same item. Guile provides you with @dfn{extended} hash tables -that permit you to specify a hash function and associator function -of your choosing. The functions described in the rest of this section -can be used to implement such custom hash table structures. - -If you are unfamiliar with the inner workings of hash tables, then -this facility will probably be a little too abstract for you to -use comfortably. If you are interested in learning more, see an -introductory textbook on data structures or algorithms for an -explanation of how hash tables are implemented. - -@deffn {Scheme Procedure} hashq key size -@deffnx {C Function} scm_hashq (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hash table of size @var{size}, where @code{eq?} is -used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. Note that -@code{hashq} may use internal addresses. Thus two calls to -hashq where the keys are @code{eq?} are not guaranteed to -deliver the same value if the key object gets garbage collected -in between. This can happen, for example with symbols: -@code{(hashq 'foo n) (gc) (hashq 'foo n)} may produce two -different values, since @code{foo} will be garbage collected. -@end deffn - -@deffn {Scheme Procedure} hashv key size -@deffnx {C Function} scm_hashv (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hash table of size @var{size}, where @code{eqv?} is -used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. Note that -@code{(hashv key)} may use internal addresses. Thus two calls -to hashv where the keys are @code{eqv?} are not guaranteed to -deliver the same value if the key object gets garbage collected -in between. This can happen, for example with symbols: -@code{(hashv 'foo n) (gc) (hashv 'foo n)} may produce two -different values, since @code{foo} will be garbage collected. +@deffnx {C Function} scm_hashq_remove_x (table, key) +@deffnx {C Function} scm_hashv_remove_x (table, key) +Remove any association for @var{key} in the given hash @var{table}. +If @var{key} is not in @var{table} then nothing is done. @end deffn @deffn {Scheme Procedure} hash key size +@deffnx {Scheme Procedure} hashq key size +@deffnx {Scheme Procedure} hashv key size @deffnx {C Function} scm_hash (key, size) -Determine a hash value for @var{key} that is suitable for -lookups in a hash table of size @var{size}, where @code{equal?} -is used as the equality predicate. The function returns an -integer in the range 0 to @var{size} - 1. -@end deffn +@deffnx {C Function} scm_hashq (key, size) +@deffnx {C Function} scm_hashv (key, size) +Return a hash value for @var{key}. This is a number in the range +@math{0} to @math{@var{size}-1}, which is suitable for use in a hash +table of the given @var{size}. -@deffn {Scheme Procedure} hashx-ref hash assoc table key [dflt] -@deffnx {C Function} scm_hashx_ref (hash, assoc, table, key, dflt) -This behaves the same way as the corresponding @code{ref} -function, but uses @var{hash} as a hash function and -@var{assoc} to compare keys. @code{hash} must be a function -that takes two arguments, a key to be hashed and a table size. -@code{assoc} must be an associator function, like @code{assoc}, -@code{assq} or @code{assv}. +Note that @code{hashq} and @code{hashv} may use internal addresses of +objects, so if an object is garbage collected and re-created it can +have a different hash value, even when the two are notionally +@code{eq?}. For instance with symbols, -By way of illustration, @code{hashq-ref table key} is -equivalent to @code{hashx-ref hashq assq table key}. -@end deffn +@example +(hashq 'something 123) @result{} 19 +(gc) +(hashq 'something 123) @result{} 62 +@end example -@deffn {Scheme Procedure} hashx-set! hash assoc table key val -@deffnx {C Function} scm_hashx_set_x (hash, assoc, table, key, val) -This behaves the same way as the corresponding @code{set!} -function, but uses @var{hash} as a hash function and -@var{assoc} to compare keys. @code{hash} must be a function -that takes two arguments, a key to be hashed and a table size. -@code{assoc} must be an associator function, like @code{assoc}, -@code{assq} or @code{assv}. - - By way of illustration, @code{hashq-set! table key} is -equivalent to @code{hashx-set! hashq assq table key}. -@end deffn - -@deffn {Scheme Procedure} hashq-get-handle table key -@deffnx {C Function} scm_hashq_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{eq?} for equality testing. -@end deffn - -@deffn {Scheme Procedure} hashv-get-handle table key -@deffnx {C Function} scm_hashv_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{eqv?} for equality testing. +In normal use this is not a problem, since an object entered into a +hash table won't be garbage collected until removed. It's only if +hashing calculations are somehow separated from normal references that +its lifetime needs to be considered. @end deffn @deffn {Scheme Procedure} hash-get-handle table key +@deffnx {Scheme Procedure} hashq-get-handle table key +@deffnx {Scheme Procedure} hashv-get-handle table key +@deffnx {Scheme Procedure} hashx-get-handle hash assoc table key @deffnx {C Function} scm_hash_get_handle (table, key) -This procedure returns the @code{(key . value)} pair from the -hash table @var{table}. If @var{table} does not hold an -associated value for @var{key}, @code{#f} is returned. -Uses @code{equal?} for equality testing. -@end deffn - -@deffn {Scheme Procedure} hashx-get-handle hash assoc table key +@deffnx {C Function} scm_hashq_get_handle (table, key) +@deffnx {C Function} scm_hashv_get_handle (table, key) @deffnx {C Function} scm_hashx_get_handle (hash, assoc, table, key) -This behaves the same way as the corresponding -@code{-get-handle} function, but uses @var{hash} as a hash -function and @var{assoc} to compare keys. @code{hash} must be -a function that takes two arguments, a key to be hashed and a -table size. @code{assoc} must be an associator function, like -@code{assoc}, @code{assq} or @code{assv}. -@end deffn - -@deffn {Scheme Procedure} hashq-create-handle! table key init -@deffnx {C Function} scm_hashq_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. -@end deffn - -@deffn {Scheme Procedure} hashv-create-handle! table key init -@deffnx {C Function} scm_hashv_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. +Return the @code{(@var{key} . @var{value})} pair for @var{key} in the +given hash @var{table}, or @code{#f} if @var{key} is not in +@var{table}. @end deffn @deffn {Scheme Procedure} hash-create-handle! table key init +@deffnx {Scheme Procedure} hashq-create-handle! table key init +@deffnx {Scheme Procedure} hashv-create-handle! table key init +@deffnx {Scheme Procedure} hashx-create-handle! hash assoc table key init @deffnx {C Function} scm_hash_create_handle_x (table, key, init) -This function looks up @var{key} in @var{table} and returns its handle. -If @var{key} is not already present, a new handle is created which -associates @var{key} with @var{init}. +@deffnx {C Function} scm_hashq_create_handle_x (table, key, init) +@deffnx {C Function} scm_hashv_create_handle_x (table, key, init) +@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) +Return the @code{(@var{key} . @var{value})} pair for @var{key} in the +given hash @var{table}. If @var{key} is not in @var{table} then +create an entry for it with @var{init} as the value, and return that +pair. @end deffn -@deffn {Scheme Procedure} hashx-create-handle! hash assoc table key init -@deffnx {C Function} scm_hashx_create_handle_x (hash, assoc, table, key, init) -This behaves the same way as the corresponding -@code{-create-handle} function, but uses @var{hash} as a hash -function and @var{assoc} to compare keys. @code{hash} must be -a function that takes two arguments, a key to be hashed and a -table size. @code{assoc} must be an associator function, like -@code{assoc}, @code{assq} or @code{assv}. +@deffn {Scheme Procedure} hash-map proc table +@deffnx {Scheme Procedure} hash-for-each proc table +@deffnx {C Function} scm_hash_map (proc, table) +@deffnx {C Function} scm_hash_for_each (proc, table) +Apply @var{proc} to the entries in the given hash @var{table}. Each +call is @code{(@var{proc} @var{key} @var{value})}. @code{hash-map} +returns a list of the results from these calls, @code{hash-for-each} +discards the results and returns unspecified value. + +Calls are made over the table entries in an unspecified order, and for +@code{hash-map} the order of the values in the returned list is +unspecified. Results will be unpredictable if @var{table} is modified +while iterating. + +For example the following returns a new alist comprising all the +entries from @code{mytable}, in no particular order. + +@example +(hash-map cons mytable) +@end example @end deffn @deffn {Scheme Procedure} hash-fold proc init table @deffnx {C Function} scm_hash_fold (proc, init, table) -An iterator over hash-table elements. -Accumulates and returns a result by applying PROC successively. -The arguments to PROC are "(key value prior-result)" where key -and value are successive pairs from the hash table TABLE, and -prior-result is either INIT (for the first application of PROC) -or the return value of the previous application of PROC. -For example, @code{(hash-fold acons '() tab)} will convert a hash -table into an a-list of key-value pairs. +Accumulate a result by applying @var{proc} to the elements of the +given hash @var{table}. Each call is @code{(@var{proc} @var{key} +@var{value} @var{prior-result})}, where @var{key} and @var{value} are +from the @var{table} and @var{prior-result} is the return from the +previous @var{proc} call. For the first call, @var{prior-result} is +the given @var{init} value. + +Calls are made over the table entries in an unspecified order. +Results will be unpredictable if @var{table} is modified while +@code{hash-fold} is running. + +For example, the following returns a count of how many keys in +@code{mytable} are strings. + +@example +(hash-fold (lambda (key value prior) + (if (string? key) (1+ prior) prior)) + 0 mytable) +@end example @end deffn From 5578a53f9ba956c12371a8aa216739dc3b0d1727 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 17 Aug 2003 00:36:04 +0000 Subject: [PATCH 017/109] * boot-9.scm (while): Use a new key dynamically for each loop, so break and continue associate to their loop even when recursing. --- ice-9/boot-9.scm | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 93f3bf365..afdaec18d 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -2554,19 +2554,25 @@ ;;; ;; The inner `do' loop avoids re-establishing a catch every iteration, -;; that's only necessary if continue is actually used. +;; that's only necessary if continue is actually used. A new key is +;; generated every time, so break and continue apply to their originating +;; `while' even when recursing. `while-helper' is an easy way to keep the +;; `key' binding away from the cond and body code. ;; (define-macro (while cond . body) - (let ((key (make-symbol "while-key"))) - `(,do ((break ,(lambda () (throw key #t))) - (continue ,(lambda () (throw key #f)))) - ((,catch (,quote ,key) - (,lambda () + (define (while-helper proc) + (do ((key (make-symbol "while-key"))) + ((catch key + (lambda () + (proc (lambda () (throw key #t)) + (lambda () (throw key #f)))) + (lambda (key arg) arg))))) + `(,while-helper (,lambda (break continue) (,do () ((,not ,cond)) ,@body) - #t) - ,(lambda (key arg) arg)))))) + #t))) + ;;; {Module System Macros} From cc08aafdaf089d9fc76d49898fad32ca9f4d952e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 17 Aug 2003 00:40:33 +0000 Subject: [PATCH 018/109] (while): Exercise break and continue from recursive nested loops. --- test-suite/tests/syntax.test | 37 ++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test index bbdda2735..6aa33eebb 100644 --- a/test-suite/tests/syntax.test +++ b/test-suite/tests/syntax.test @@ -675,6 +675,22 @@ (outer-break) (unreachable))) (unreachable)) + #t) + + (pass-if "from recursive" + (let ((outer-break #f)) + (define (r n) + (while #t + (if (eq? n 'outer) + (begin + (set! outer-break break) + (r 'inner)) + (begin + (outer-break) + (unreachable)))) + (if (eq? n 'inner) + (error "broke only from inner loop"))) + (r 'outer)) #t)) (with-test-prefix "continue" @@ -717,4 +733,25 @@ (while #t (outer-continue) (unreachable))))) + #t) + + (pass-if "from recursive" + (let ((outer-continue #f)) + (define (r n) + (let ((cond (make-iterations-cond 3)) + (first #t)) + (while (begin + (if (and (not first) + (eq? n 'inner)) + (error "continued only to inner loop")) + (cond)) + (set! first #f) + (if (eq? n 'outer) + (begin + (set! outer-continue continue) + (r 'inner)) + (begin + (outer-continue) + (unreachable)))))) + (r 'outer)) #t))) From 2388d9af3e7d43e93c690e2c9f344a2a51b1513c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sun, 17 Aug 2003 00:40:59 +0000 Subject: [PATCH 019/109] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ test-suite/ChangeLog | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 5ce4226db..e5a51af18 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-08-17 Kevin Ryde + + * boot-9.scm (while): Use a new key dynamically for each loop, so + break and continue associate to their loop even when recursing. + 2003-08-14 Kevin Ryde * boot-9.scm (while): Rewrite, continue as proper escape, break diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index de576426f..b2fa5bc00 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,8 @@ +2003-08-17 Kevin Ryde + + * tests/syntax.test (while): Exercise break and continue from + recursive nested loops. + 2003-08-14 Kevin Ryde * tests/syntax.test (while): New tests. From db24983896ecc30853707cfbf684ca9b1d9414d9 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Wed, 20 Aug 2003 19:00:44 +0000 Subject: [PATCH 020/109] Import Mikael's Emacs interface code (guileint-1.5.2) into Guile CVS. --- emacs/ChangeLog | 6 + emacs/README | 1 + emacs/guileint/ChangeLog | 235 +++ emacs/guileint/README | 0 emacs/guileint/README.mdj | 0 emacs/guileint/cmuscheme.el.diff | 0 emacs/guileint/comint.el.diff | 0 emacs/guileint/defmenu.el | 94 ++ emacs/guileint/fcreate.el | 0 emacs/guileint/guile-init.el | 152 ++ emacs/guileint/guile.el | 2457 ++++++++++++++++++++++++++++++ emacs/guileint/guileint.el | 117 ++ emacs/guileint/inda-scheme.el | 201 +++ emacs/guileint/scheme.el.diff | 0 emacs/guileint/xscheme.el.diff | 0 15 files changed, 3263 insertions(+) create mode 100644 emacs/guileint/ChangeLog create mode 100644 emacs/guileint/README create mode 100644 emacs/guileint/README.mdj create mode 100644 emacs/guileint/cmuscheme.el.diff create mode 100644 emacs/guileint/comint.el.diff create mode 100644 emacs/guileint/defmenu.el create mode 100644 emacs/guileint/fcreate.el create mode 100644 emacs/guileint/guile-init.el create mode 100644 emacs/guileint/guile.el create mode 100644 emacs/guileint/guileint.el create mode 100644 emacs/guileint/inda-scheme.el create mode 100644 emacs/guileint/scheme.el.diff create mode 100644 emacs/guileint/xscheme.el.diff diff --git a/emacs/ChangeLog b/emacs/ChangeLog index 5189f107f..4d7b0bf53 100644 --- a/emacs/ChangeLog +++ b/emacs/ChangeLog @@ -1,3 +1,9 @@ +2003-08-20 Neil Jerram + + * guileint: New subdirectory. + + * README: Mention it. + 2001-11-19 Thien-Thi Nguyen * README: Use less forking for indexing command. diff --git a/emacs/README b/emacs/README index 73e021581..4d39c6111 100644 --- a/emacs/README +++ b/emacs/README @@ -9,5 +9,6 @@ patch.el --- mail/apply a patch ppexpand.el --- temporarily expanding macros in a pretty way. update-changelog.el --- stitch rcs2log output to ChangeLog +guileint --- directory containing experimental Emacs interface for Guile Generated using: for f in *.el ; do sed -e 's/^....//g' -e '1q' $f ; done diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog new file mode 100644 index 000000000..11c6de786 --- /dev/null +++ b/emacs/guileint/ChangeLog @@ -0,0 +1,235 @@ +2003-08-20 Neil Jerram + + Import of Mikael's guileint-1.5.2.tgz into Guile CVS ... + + * defmenu.el, fcreate.el, guile-init.el, guile.el, guileint.el, + inda-scheme.el: Imported unchanged. + + * cmuscheme.el.diff, comint.el.diff, scheme.el.diff, + xscheme.el.diff: Created by diffing Mikael's versions against the + nearest revisions I could find in Emacs CVS, so as to show the + changes made. + + * README.mdj: Renamed from Mikael's `README'. + + * README: New. + +1999-08-23 Mikael Djurfeldt + + * guile.el (guile-frame-eval): Made interactive. + (guile-error-map): Added guile-frame-eval under "e". + +1999-03-17 Mikael Djurfeldt + + * guile.el (guile-file-readable-p, guile-find-file-noselect): New + functions. Sets buffer to scheme-buffer before doing there + action. + (guile-display-scheme-sexp): Use the above functions. + +1999-03-16 Mikael Djurfeldt + + * guile.el (guile-buffer-file-name): Version of buffer-file-name + which uses file-truename; + Use guile-buffer-file-name throughout. + +1999-03-15 Mikael Djurfeldt + + * guileint.el: Add conditional in order not to load the interface + multiple times. + + * guile.el (scheme-virtual-file-list-find): New function. Finds + an finfo entry using a file name. Uses `file-truename'; + Replaced all assoc calls with scheme-vertual-file-list-find + everywhere. + (guile-real-safe-backward-sexp): New function. Can skip backwards + over special scheme hash-syntax. + (guile-send-input): Use `guile-real-safe-backward-sexp'. + +1999-03-01 Mikael Djurfeldt + + * inda-scheme.el (scheme-electric-open-paren), + guile.el (guile-indent-or-complete): Use indent-for-tab-command + instead of scheme-indent-line. + + * scheme.el: Merge changes from Emacs-20.3. + +1998-06-18 Mikael Djurfeldt + + * guile.el (guile-send-region): Bugfix: Calculate new value for + start if overlays have been skipped. + (guile-send-overlay): Send define-module overlay to define the + module before sending any other overlay belonging to that module. + (guile-reparse-buffer): Detect define-module expressions. + +1998-06-14 Mikael Djurfeldt + + * guile.el (guile-select-stackframe): Increment line number. + +1998-06-10 Mikael Djurfeldt + + * guile.el: Removed calls to the former debugging function `cb'. + +1998-05-21 Mikael Djurfeldt + + * guile.el: Added nil nil t arguments in calls to make-overlay in + order to make the overlays rear-sticky. (This is an adaption to + Emacs-20.) + +1997-10-22 Mikael Djurfeldt + + * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20. + +Wed Oct 1 22:02:19 1997 Mikael Djurfeldt + + * inda-scheme.el (inda-inferior-initializations): Disable + font-lock-mode in inferior-scheme buffers. (For some strange + reason, the inda-read-only-overlay modification hook gets called + when a character is inserted after the prompt if font-lock mode + has been activated.) + +Fri Aug 29 01:34:34 1997 Mikael Djurfeldt + + * guile.el (guile-display-name): Bugfix: filler --> + guile-define-filler. + (guile-send-overlay): Bugfix: Don't print "DEFINED" if start /= + overlay-start. + Added (require 'cl). + (guile-insert-before-prompt): Use guile-last-output-end + +Wed Aug 27 17:24:28 1997 Mikael Djurfeldt + + * guile.el (guile-complete-symbol): Bugfix: Don't do anything if + word is nil. + (guile-backtrace-in-source-window): New customization option. + (guile-display-error): Don't place backtrace in source window if + guile-backtrace-in-source-window is nil. + (guile-prep-backtrace): Set syntax-table to + scheme-mode-syntax-table. + +Tue Aug 26 00:01:01 1997 Mikael Djurfeldt + + * guile.el (guile-insert-before-prompt): Move the recenter code + here. + (guile-display-name): Use guile-insert-before-prompt. + +Mon Aug 25 22:46:23 1997 Mikael Djurfeldt + + * guile.el (guile-display-name): Recenter display if prompt + started at the beginning of the buffer, so that the first text + inserted before prompt will be visible. + +Mon Aug 25 19:36:50 1997 Mikael Djurfeldt + + * guile.el: New variable: guile-frame-overlay. + (guile-inferior-initialize): Initialize guile-frame-overlay to + nil. + (guile-place-frame-overlay, guile-turn-off-frame-overlay, + guile-unselect-stackframe): New functions. + (guile-unselect-stackframe): Turn off overlay and set + guile-selected-frame to nil. + (guile-stack-frame): New overlay category. + (guile-selected-frame): defun --> defvar + (guile-exit-debug): Turn off frame overlay. + (guile-prep-backtrace): Call `guile-unselect-stackframe'. + (guile-turn-off-sexp-overlay, guile-turn-off-frame-overlay): Check + (car args) before applying `delete-overlay'. + (guile-error-map): Bind S-mouse-2 to guile-frame-eval-at-click. + + * inda-scheme.el (inda-scheme-mode-initializations): Bind + S-mouse-2 to guile-frame-eval-at-click; Bind M-TAB to + guile-complete-symbol. + + * guile.el (guile-complete-symbol): Made a command. + (guile-frame-eval-at-click, guile-frame-eval): New functions. + Enables clicking on expressions in the source buffer to show their + values. + (guile-complete-symbol, guile-list-completions): Bugfix: Use + `buffer-name' instead of `current-buffer' in order to obtain the + buffer name. + (guile-select-frame): Always set guile-selected-frame. + +Mon Aug 25 16:21:18 1997 Mikael Djurfeldt + + * guile.el (guile-eval): Must wait for scheme-ready-p so that the + filter functions don't get called. + (guile-describe-variable): Put `guile-force-splittable' around + call to `with-output-to-temp-buffer' so that documentation can be + displayed also in *scheme* window even if it is dedicated. + +Sun Aug 24 22:19:16 1997 Mikael Djurfeldt + + * *** Transferred code to guile-emacs. *** + + * inda-scheme.el (inda-inferior-initializations): Removed + assignment to scheme-pop-to-buffer. + +Thu Aug 21 01:47:31 1997 Mikael Djurfeldt + + * guile.el (guile-eval-result, guile-receive-result, guile-eval): + guile-eval-result now contains the printed representation as a + string instead of an elisp object. + (guile-eval-output): New variable. + (guile-receive-result): Set guile-eval-output to + guile-unallowed-output. + (guile-define-startcol, guile-define-filler, + guile-define-fillcol): New variables. Buffer-local. + (guile-define-header-emitted-p): New variable. + (scheme-send-region): Print result of last sent overlay or show + message "Defined." if definitions have been made. + (guile-insert-before-prompt): Don't use guile-pre-prompt-marker. + (guile-pre-prompt-marker): New name: guile-define-name-marker. + (guile-send-region): Moved printing of defined names to + guile-display-name. + (guile-send-overlay): New parameters; Zeros guile-eval-output; + Adapted to new format of %%emacs-load; Can now send sub-parts of + an overlay; Use guile-display-name. + (guile-display-name): New function. + (guile-receive-result): Reset guile-unallowed-output after having + stored its value in guile-eval-output. + +Sat Aug 16 02:53:00 1997 Mikael Djurfeldt + + * guile.el (guile-display-error): Limit height of *Scheme Error* + window to half of guile-backtrace-max-height. + +Thu Jul 24 18:41:56 1997 Mikael Djurfeldt + + * guile.el (guile-normal-edit): Don't set + scheme-buffer-modified-p. This will be done by + guile-scheme-buffer-modified next time the buffer is modified. + (guile-scheme-buffer-modified): New function. + (guile-inferior-initialize): Make first-change-hook buffer-local, + add guile-scheme-modified; Pass t for initialp to + guile-enhanced-edit if the scheme-buffer seems untouched. + + * guile.el (guile-normal-edit): Unlink overlays and buffer. + + * inda-scheme.el (inda-send-definition, inda-mark-sexp): Make it + possible to send expressions to scheme just by clicking on them. + + * guileint.el: Removed statements that doesn't have anything to do + with the Guile interface per se (transient-mark-mode, iso-syntax + etc) + +Wed Jul 23 19:11:15 1997 Mikael Djurfeldt + + * inda-scheme.el: Changed inda menu --> interpret. + +Thu Jul 17 10:43:58 1997 Mikael Djurfeldt + + * inda96.el (devel-binary): Changed to unstable. + + * guile.el (guile-display-buffers): Check for window system before + deleting windows on buffer1. + (guile-get-create-error-window): Treat non-window system + differently. + (scheme-send-region): Don't check for (scheme-ready-p) here. This + is checked in guile-send-region. + (guile-send-region): Check for (scheme-ready-p) here instead. + Go to end-of-buffer before determining proper place for "DEFINED + %s (". + +Tue Oct 15 16:56:18 1996 Mikael Djurfeldt + + * Start of revision history for misc elisp files. + diff --git a/emacs/guileint/README b/emacs/guileint/README new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/README.mdj b/emacs/guileint/README.mdj new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/cmuscheme.el.diff b/emacs/guileint/cmuscheme.el.diff new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/comint.el.diff b/emacs/guileint/comint.el.diff new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/defmenu.el b/emacs/guileint/defmenu.el new file mode 100644 index 000000000..d63d32182 --- /dev/null +++ b/emacs/guileint/defmenu.el @@ -0,0 +1,94 @@ +;;; @(#) defmenu.el -- A GNU Emacs extension which helps building menus +;;; @(#) $Keywords: X, menu $ + +;; Copyright (C) 1995 Mikael Djurfeldt + +;; LCD Archive Entry: +;; defmenu|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which helps building menus| +;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/defmenu.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.0 + +;; 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 of the License, 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 GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; + +(defun define-menu (keymap key name entries) + "Define a menu in KEYMAP on fake function key KEY with label NAME. +Every entry in the list ENTRIES defines a menu item and looks like this: + + (LABEL DEFINITION [ENABLE-EXP]) + +LABEL is a string which will appear in the menu. +DEFINITION is either a symbol, in which case it will be used both as +fake function key and binding, or a pair, where the car is the fake +function key and the cdr is the binding. +The optional ENABLE-EXP is an expression which will be evaluated every +time the menu is displayed. If it returns nil the menu item will +be disabled. + +You can get a separator by including nil in the ENTRIES list." + (define-key keymap + (vector 'menu-bar key) + (cons name (make-menu name entries)))) + +(defun make-menu (name entries) + "Make a menu with label NAME. +Every entry in the list ENTRIES defines a menu item and looks like this: + + (LABEL DEFINITION [ENABLE-EXP]) + +LABEL is a string which will appear in the menu. +DEFINITION is either a symbol, in which case it will be used both as +fake function key and binding, or a pair, where the car is the fake +function key and the cdr is the binding. +The optional ENABLE-EXP is an expression which will be evaluated every +time the menu is displayed. If it returns nil the menu item will +be disabled. + +You can get a separator by including nil in the ENTRIES list." + (let ((menu (make-sparse-keymap name)) + (entries (reverse entries))) + (while entries + (let ((entry (car entries))) + (if (null entry) + (define-key menu (vector (defmenu-gensym "separator")) '("--")) + (if (symbolp (nth 1 entry)) + (define-key menu (vector (nth 1 entry)) + (cons (car entry) (nth 1 entry))) + (define-key menu (vector (car (nth 1 entry))) + (cons (car entry) (cdr (nth 1 entry))))) + (if (not (null (nthcdr 2 entry))) + (put (nth 1 entry) 'menu-enable (nth 2 entry))))) + (setq entries (cdr entries))) + menu)) + +(defun defmenu-gensym (prefix) + (let ((counter (intern (concat "defmenu-" prefix "count")))) + (if (boundp counter) (set counter (1+ (symbol-value counter))) + (set counter 0)) + (intern (concat prefix (int-to-string (symbol-value counter)))))) + +(provide 'defmenu) diff --git a/emacs/guileint/fcreate.el b/emacs/guileint/fcreate.el new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/guile-init.el b/emacs/guileint/guile-init.el new file mode 100644 index 000000000..e75f4b69b --- /dev/null +++ b/emacs/guileint/guile-init.el @@ -0,0 +1,152 @@ +;;; @(#) guile-init.el -- +;;; @(#) $Keywords: $ + +;; Copyright (C) 1995 Mikael Djurfeldt + +;; LCD Archive Entry: +;; guile-init|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which | +;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.0 + +;; 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 of the License, 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 GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; + +(defvar guile-init-load-hook nil + "*Hook run when file is loaded") + +(require 'guile) + +;;; Misc. interactivity +;;; +;;; +(defun inda-barf-at-modifications (&rest args) + (or inhibit-read-only + (error "Attempt to modify read-only text"))) + +(defun inda-boldify-previous-character () + ;; Must check this so that we don't point outside buffer... + (if (> (point) (point-min)) + (let ((inhibit-read-only t)) + (put-text-property (1- (point)) (point) 'face 'bold)))) + +(defun inda-make-input-memory (string) + ;; If input consists of many lines, the read-only overlay will + ;; cover the previous line, so we have to disable the protection. + (let ((inhibit-read-only t)) + ;(setq n (1+ n) + ; l (append l (list (list n 'input-filter string)))) + (if (marker-position guile-last-output-end) + (add-text-properties guile-last-output-end (1- (point)) + '(input-memory t rear-nonsticky t mouse-face highlight))))) + +(defun inda-reset-guile-last-output (string) + ;(setq n (1+ n) + ; l (append l (list (list n 'output-filter string)))) + (if (not scheme-ready-p) + (set-marker guile-last-output-end nil))) + +(define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) +(define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) + +;; Should rather be implemented with advice. +(defun inda-mouse-yank-at-click (click arg) + "Insert the last stretch of killed text at the position clicked on. +Also move point to one end of the text thus inserted (normally the end). +Prefix arguments are interpreted as with \\[yank]. +If `mouse-yank-at-point' is non-nil, insert at point +regardless of where you click." + (interactive "e\nP") + (if (get-char-property (posn-point (event-start click)) 'input-memory) + (if (memq 'shift (event-modifiers (car click))) + (inda-insert-input-memory click) + (inda-insert-input-memory-and-send click)) + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (or mouse-yank-at-point (mouse-set-point click)) + (setq this-command 'yank) + (yank arg))) + +(defun inda-insert-input-memory (event) + (interactive "e") + (let* ((pos (posn-point (event-start event))) + (beg (previous-single-property-change (1+ pos) 'mouse-face)) + (end (next-single-property-change pos 'mouse-face))) + (goto-char (point-max)) + (let ((input-start (point))) + (comint-kill-input) + (insert (buffer-substring beg end)) + (add-text-properties input-start (point) + '(mouse-face nil + rear-nonsticky nil + input-memory nil))))) + +(defun inda-insert-input-memory-and-send (event) + (interactive "e") + (inda-insert-input-memory event) + (guile-send-input)) + +(defun inda-boldify (string) + (put-text-property comint-last-input-start (point) 'face 'bold)) + +(defun inda-extend-read-only-overlay (string) + (if guile-input-sent-p + (let ((inhibit-read-only t)) + (move-overlay inda-read-only-overlay (point-min) (point))))) + +;;; Misc. utilities +;;; +(defun scheme-send-buffer () + "Send the current buffer to the inferior Scheme process." + (interactive) + (let (begin end) + (save-excursion + (goto-char (point-max)) + (setq end (point)) + (goto-char (point-min)) + (setq begin (point))) + (scheme-send-region begin end))) + +(defun indent-buffer () + "Indent entire buffer." + (interactive) + (save-excursion + (end-of-buffer) + (let ((end (point))) + (beginning-of-buffer) + (indent-region (point) end nil)))) + +(defun indent-defun () + "Indent lisp definition." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (indent-region (point) end nil)))) + +(provide 'guile-init) +(run-hooks 'guile-init-load-hook) diff --git a/emacs/guileint/guile.el b/emacs/guileint/guile.el new file mode 100644 index 000000000..e78e4ac4d --- /dev/null +++ b/emacs/guileint/guile.el @@ -0,0 +1,2457 @@ +;;; @(#) guile.el -- A GNU Emacs interface to Guile +;;; @(#) $Keywords: guile, comint, scheme-mode $ + +;; Copyright (C) 1995, 2002 Mikael Djurfeldt + +;; LCD Archive Entry: +;; guile|djurfeldt@nada.kth.se| +;; A GNU Emacs extension which | +;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/guile.el.Z| + +;; Author: Mikael Djurfeldt +;; Version: 1.5.2 + +;; 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 of the License, 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 GNU Emacs. If you did not, write to the Free Software Foundation, +;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. + +;;; Commentary: +;; +;; Requirements: +;; +;; Usage: +;; +;; Bugs: +;; +;; +;;; ************************************************************************* +;;; * This is code is currently under development * +;;; * Mail any problems to djurfeldt@nada.kth.se * +;;; ************************************************************************* + +(require 'cl) +(require 'fcreate) + +(defvar guile-auto-attach nil) + +(defvar guile-load-hook nil + "*Hook run when file is loaded") + +;;(require 'cmuscheme) +(load "comint") ; `comint' and `cmuscheme' are already loaded. +(load "cmuscheme") ; We need to replace them. + +;; Faces are set in the cond expression below. + +(defvar guile-error-face nil + "Face used to highlight erroneous scheme forms.") + +(defvar guile-backtrace-mouse-face nil + "Face used when the mouse is over a backtrace frame.") + +(defvar guile-modified-face nil + "Face for modified top-level forms in scheme-mode buffers.") + +(defvar guile-broken-face nil + "Face for broken top-level forms in scheme-mode buffers.") + +;; These faces are used during debugging of the list parsing code. + +(defvar guile-unmodified-face-1 nil) +(defvar guile-unmodified-face-2 nil) +(defvar guile-modified-face-1 nil) +(defvar guile-modified-face-2 nil) +(defvar guile-broken-face-1 nil) +(defvar guile-broken-face-2 nil) + +;;; Customization +;;; + +(defvar guile-backtrace-in-source-window t + "*If non-nil, let backtrace windows appear in bottom of source window. +This only occurs if the erring expression can be located.") + +(defvar guile-show-runlight-in-scheme-mode nil + "*If non-nil, show process status also in attached scheme-mode buffers. +Otherwise the mode-line shows if the buffer is attached or not.") + +(defvar guile-default-enhanced-edit t + "If non-nil, automatically enter enhanced edit mode for scheme buffers.") + +(defvar guile-popup-restart-on-death t) + +(defvar guile-popup-restart-on-stop t) + +(defvar guile-insert-reason t) + +(defvar guile-kill-buffer-on-death nil) + +(defvar guile-process-timeout 500 + "Milliseconds") + +(defconst guile-backtrace-buffer-name "*Scheme Backtrace*") + +(defconst guile-error-buffer-name "*Scheme Error*") + +(defconst guile-backtrace-min-height 10) +(defconst guile-backtrace-max-height 30) +(defconst guile-backtrace-min-width 30) +(defconst guile-backtrace-max-width 90) + +(cond ((not window-system) + ;; Faces for text terminals + (setq guile-error-face 'modeline) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face nil) + (setq guile-unmodified-face-1 nil) + (setq guile-unmodified-face-2 'modeline) + (setq guile-modified-face-1 'bold) + (setq guile-modified-face-2 guile-error-face) + (setq guile-broken-face-1 nil) + (setq guile-broken-face-2 nil)) + ((x-display-color-p) + ;; Faces for color screens + (setq guile-error-face (lookup-face-create 'black/red-bold)) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face 'bold) + (setq guile-unmodified-face-1 (lookup-face-create 'black/lightblue)) + (setq guile-unmodified-face-2 'secondary-selection) + (setq guile-modified-face-1 'highlight) + (setq guile-modified-face-2 (lookup-face-create 'black/pink)) + (setq guile-broken-face-1 + (let ((face (make-face 'broken-form-1))) + (copy-face guile-modified-face-1 face) + (set-face-underline-p face t) + face)) + (setq guile-broken-face-2 + (let ((face (make-face 'broken-form-2))) + (copy-face guile-modified-face-2 face) + (set-face-underline-p face t) + face))) + (t + ;; Faces for monochrome screens + (setq guile-error-face (lookup-face-create 'white/black-bold)) + (setq guile-backtrace-mouse-face 'highlight) + (setq guile-modified-face nil) ; no special face + (setq guile-broken-face 'bold) + (setq guile-unmodified-face-1 nil) + (setq guile-unmodified-face-2 'modeline) + (setq guile-modified-face-1 'bold) + (setq guile-modified-face-2 guile-error-face) + (setq guile-broken-face-1 + (let ((face (make-face 'broken-form-1))) + (copy-face guile-modified-face-1 face) + (set-face-underline-p face t) + face)) + (setq guile-broken-face-2 + (let ((face (make-face 'broken-form-2))) + (copy-face guile-modified-face-2 face) + (set-face-underline-p face t) + face)))) + +(if (not (fboundp 'lisp-mode-auto-fill)) + (defun lisp-mode-auto-fill () + (if (> (current-column) (current-fill-column)) + (if (save-excursion + (nth 4 (parse-partial-sexp (save-excursion + (beginning-of-defun) + (point)) + (point)))) + (do-auto-fill) + (let ((comment-start nil) (comment-start-skip nil)) + (do-auto-fill)))))) + +(defconst guile-symclash-obarray-size 521) + +(defconst guile-big-integer 33333333) + +;;; Mode initializers +;;; + +(defvar guile-inferior-scheme-frame nil) + +;; Inferior Scheme Mode +;; +(defun guile-inferior-initialize () + ;; Buffer local variables + (make-local-variable 'guile-eval-result) + (make-local-variable 'guile-eval-output) + (make-local-variable 'guile-last-output-end) + (make-local-variable 'guile-last-prompt-end) + (make-local-variable 'guile-define-name-marker) + (make-local-variable 'guile-unallowed-output) + (make-local-variable 'guile-define-startcol) + (make-local-variable 'guile-define-filler) + (make-local-variable 'guile-define-fillcol) + (set-process-sentinel (scheme-proc) (function guile-sentinel)) + (setq comint-dispatch-alist guile-dispatch-alist) + (add-hook 'comint-input-filter-functions + (function guile-sync-on-input) nil 'local) + (add-hook 'comint-unallowed-output-filter-functions + (function guile-remember-unallowed-output) nil 'local) + (setq comint-dynamic-complete-functions '(guile-complete-symbol)) + (make-local-hook 'scheme-enter-input-wait-hook) + ;; Some initializations + (setq scheme-ready-p nil) + (setq scheme-load-p nil) + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (setq guile-last-output-end (make-marker)) + (setq guile-last-prompt-end (make-marker)) + (setq guile-input-sent-p t) + (setq guile-define-name-marker (make-marker)) + (setq guile-error-p nil) + (setq guile-sexp-overlay nil) + (setq guile-frame-overlay nil) + (let ((enhanced (guile-get-enhanced-buffers))) + (and scheme-buffer (guile-detach-all)) + (for-each (function guile-normal-edit) enhanced) + (guile-kill-overlays) + (for-each (function (lambda (buffer) + (save-excursion + (set-buffer buffer) + (guile-enhanced-edit + buffer + (not scheme-buffer-modified-p))))) + enhanced)) + (setq guile-synchronizedp t) + (setq comint-allow-output-p t) + (setq guile-unallowed-output nil) + ) + +(defvar default-handle-switch-frame-binding + (lookup-key global-map [switch-frame])) +(define-key global-map [switch-frame] 'guile-handle-switch-frame) + +(defun guile-handle-switch-frame (event) + (interactive "e") + (let ((frame (nth 1 event))) + (if (eq frame guile-inferior-scheme-frame) + (guile-sync-with-scheme)) + (funcall default-handle-switch-frame-binding frame))) + +(defun guile-sync-on-input (string) + (if scheme-load-p + (progn + nil)) + (setq guile-error-p nil) ;; What is this??? *fixme* + (guile-sync-with-scheme) + (if guile-error-p + (progn + ;; The read-only-overlay extends during transfer of error and + ;; backtrace information. Check why! *fixme* + (let ((inhibit-read-only t)) + (comint-kill-input)) + ;; By generating an error we interrupt the execution + ;; of the comint-input-filter-functions hook. + (error "Bad expression! Please correct.")))) + +(defvar guile-unallowed-output nil) + +(defun guile-remember-unallowed-output (string) + (if guile-unallowed-output + (setq guile-unallowed-output + (concat guile-unallowed-output string)))) + +(add-hook 'inferior-scheme-mode-hook (function guile-inferior-initialize)) + +;; Scheme Mode +;; +(defvar scheme-buffer-overlays () + "The overlays containing top-level sexps when in enhanced edit mode. +A nil value indicates that the buffer is not in enhanced edit mode.") + +(defvar scheme-buffer-last-overlay nil + "When in enhanced edit mode, this variable contains the lowermost +overlay.") + +(defvar scheme-buffer-modified-p nil + "Non-nil if any overlay has been modified since last synchronization.") + +(defvar scheme-buffer-overlays-modified-p nil) + +(defvar scheme-associated-process-buffer nil + "The buffer of the scheme process to which this buffer is associated. +A value of nil means that this buffer is detached.") + +(defvar scheme-overlay-repair-function nil) + +(make-variable-buffer-local 'scheme-overlay-repair-function) + +(defvar scheme-overlay-repair-idle-timer nil) + +(defun guile-scheme-mode-initialize () + "Initialize a scheme mode buffer." + (make-local-variable 'scheme-buffer-overlays) + (make-local-variable 'scheme-buffer-modified-p) + (make-local-variable 'scheme-buffer-last-overlay) + (make-local-variable 'scheme-buffer-overlays-modified-p) + (make-local-variable 'scheme-associated-process-buffer) + (make-local-variable 'guile-last-broken) + (make-local-variable 'guile-repair-limit) + (make-local-hook 'first-change-hook) + (add-hook 'first-change-hook (function guile-scheme-buffer-modified) nil t) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook (function guile-scheme-mode-cleanup) nil t) + (if guile-default-enhanced-edit + (guile-enhanced-edit (current-buffer) + ;; If buffer not modified, take a chance... + (and (not scheme-buffer-modified-p) + (not (buffer-modified-p (current-buffer)))) + )) + ) + +(add-hook 'scheme-mode-hook (function guile-scheme-mode-initialize)) + +(defun guile-scheme-buffer-modified () + (setq scheme-buffer-modified-p t)) + +(defun guile-scheme-mode-cleanup () + (if (guile-attachedp (current-buffer)) + (progn + (guile-sync-buffer (current-buffer)) + (guile-detach-buffer (current-buffer)))) + (if (guile-enhancedp (current-buffer)) + (guile-normal-edit (current-buffer)))) + +;;; User interface support +;;; + +(defun guile-clear-transcript () + "Delete all text before the last prompt in the scheme process buffer." + (interactive) + (if (or (not (buffer-name)) + (not (string= (buffer-name) scheme-buffer))) + (error "This command must be issued in the scheme process buffer!")) + (save-excursion + (goto-char (or (marker-position guile-last-prompt-end) + (point-max))) + (if (re-search-backward comint-prompt-regexp nil t) + (goto-char (match-beginning 0)) + (beginning-of-line)) + (let ((inhibit-read-only t)) + (delete-region (point-min) (point))))) + +(defun guile-switch-to-scheme () + "Switch to the scheme process buffer and places cursor at the end. +Also update the scheme process with all changes made in attached buffers." + (interactive) + (guile-sync-with-scheme) + ;(if (not guile-error-p) + ; (switch-to-scheme t)) + (switch-to-scheme t)) + +;;; Process control +;;; +;(defvar scheme-running-p nil +; "This variable, if nil, indicates that the process is waiting for input.") + +(defvar scheme-ready-p nil + "If non-nil, the process is waiting for input at the top-level repl.") + +(defvar scheme-load-p nil) + +(defvar guile-no-stack-p nil) + +(defvar guile-no-source-p nil) + +(defun guile-inferior-dialog (contents) + (let ((window (display-buffer "*scheme*"))) + (x-popup-dialog window contents))) + +(defun guile-sentinel (process reason) + (let ((status (process-status process))) + (if guile-insert-reason + (let ((old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer (process-buffer process)) + (goto-char (point-max)) + (insert reason) + (goto-char (point-max)) + (sit-for 0)) + (set-buffer old-buffer)))) + (cond ((eq status 'run) + (scheme-set-runlight scheme-last-runlight)) + ((eq status 'stop) + (scheme-set-runlight 'stopped) + (if guile-popup-restart-on-stop + (if (guile-inferior-dialog '("The scheme process has been stopped. +Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) + (continue-process process)))) + (t + (guile-inferior-death-cleanup) + (if guile-popup-restart-on-death + (if (guile-inferior-dialog '("The scheme process has died. +Do you want to restart it?" ("Yes" . t) nil ("No" . nil))) + (run-scheme scheme-program-name) + (or guile-kill-buffer-on-death + (kill-buffer "*scheme*"))) + (or guile-kill-buffer-on-death + (kill-buffer "*scheme*"))))))) + +(defun guile-inferior-death-cleanup () + (scheme-set-runlight nil) + (setq scheme-ready-p nil) + (setq scheme-virtual-file-list nil) + (guile-detach-all)) + +;; It would be too late to set this variable in the inferior-scheme-mode-hook: +;;(setq comint-output-filter-function (function comint-dispatch-output-filter)) +;; *fixme* This should rather be done with advice. + +(defun run-scheme (cmd) + "Run an inferior Scheme process, input and output via buffer *scheme*. +If there is a process already running in *scheme*, just switch to that buffer. +With argument, allows you to edit the command line (default is value +of scheme-program-name). Runs the hooks from inferior-scheme-mode-hook +\(after the comint-mode-hook is run). +\(Type \\[describe-mode] in the process buffer for a list of commands.)" + + (interactive (list (if current-prefix-arg + (read-string "Run Scheme: " scheme-program-name) + scheme-program-name))) + (if (not (comint-check-proc "*scheme*")) + (let ((cmdlist (scheme-args-to-list cmd)) + (comint-output-filter-function + (function comint-dispatch-output-filter))) + (set-buffer (apply 'make-comint "scheme" (car cmdlist) + nil (cdr cmdlist))) + (inferior-scheme-mode))) + (setq scheme-program-name cmd) + (setq scheme-buffer "*scheme*") + (pop-to-buffer "*scheme*") + ;; *fixme* Ugly to specialize `run-scheme' in this way... + (setq guile-inferior-scheme-frame (selected-frame))) + +(defun guile-restart-scheme () + (interactive) + (let ((old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer scheme-buffer) + (let ((attached-buffers inferior-scheme-associated-buffers)) + (guile-shutdown) + (let ((inhibit-read-only t)) + (erase-buffer)) + (setq comint-allow-output-p t) + (run-scheme scheme-program-name) + ;(sit-for 0 200) + (for-each (function (lambda (buffer) + (if (buffer-name buffer) + (guile-attach-buffer buffer)))) + (reverse attached-buffers)))) + (set-buffer old-buffer)))) + +(defun guile-shutdown () + (interactive) + (let ((guile-popup-restart-on-death nil) + (old-buffer (current-buffer))) + (unwind-protect + (progn + (set-buffer scheme-buffer) + (setq comint-allow-output-p nil) ; Hide output + (setq guile-unallowed-output nil) + (if scheme-ready-p + (let ((inhibit-read-only t)) + (comint-kill-input) + (comint-send-string (scheme-proc) "(quit)\n") + (let ((countdown 5)) + (while (and scheme-ready-p (> countdown 0)) + (sit-for 0 300) + (setq countdown (1- countdown)))))) + (sit-for 0 100) + (if (comint-check-proc "*scheme*") + (progn + (kill-process (scheme-proc)) + (while (comint-check-proc "*scheme*") + (sit-for 0 300)))) + (sit-for 0 100)) + (set-buffer old-buffer)))) + +(defun guile-exit-scheme () + "Stop the running scheme process and kill the corresponding window" + (interactive) + (guile-shutdown) + (if (not (comint-check-proc "*scheme*")) + (kill-buffer "*scheme*"))) + +;;; Basic process protocol + +(setq guile-dispatch-alist + '((?f scheme-exit-input-wait scheme:simple-action) + (?l scheme-load-acknowledge scheme:simple-action) + (?r scheme-enter-read scheme:simple-action) + (?s scheme-enter-input-wait scheme:simple-action) + (?B guile-receive-backtrace scheme:buffer-action) + (?F guile-receive-error scheme:buffer-action) + (?x guile-receive-result scheme:string-action) + (?S guile-no-stack scheme:simple-action) + (?R guile-no-source scheme:simple-action) + )) + +(defun scheme:simple-action (action) + (setq comint-dispatch-state 'idle) + (funcall action)) + +(defun scheme:string-action (action) + (setq comint-string-receiver action) + (setq comint-string-accumulator "") + (setq comint-dispatch-state 'reading-string)) + +(defun scheme:buffer-action (action) + (setq comint-buffer-receiver action) + (setq comint-receiving-buffer (generate-new-buffer "*receiving-buffer*")) + (setq comint-dispatch-state 'reading-to-buffer)) + +;;; Guile protocol + +(defun guile-no-stack () + (setq guile-no-stack-p t)) + +(defun guile-no-source () + (setq guile-no-source-p t)) + +(defvar guile-eval-result nil) +(defvar guile-eval-output nil) + +(defun guile-receive-result (string) + (setq comint-allow-output-p nil) + (setq guile-eval-result string) + (setq guile-eval-output guile-unallowed-output) + (setq guile-unallowed-output nil)) + +(defun guile-eval (sexp &optional stringp) + (let ((process (scheme-proc)) ;*fixme* + (comint-input-filter-functions '()) + (comint-output-filter-functions '())) + (if (not scheme-ready-p) + (error "Scheme process not ready to receive commands.")) + (setq guile-eval-result nil) + (comint-send-string process + (format "(%%%%emacs-eval-request '%S)\n" sexp)) + (while (not guile-eval-result) + (accept-process-output process)) + (while (not scheme-ready-p) + (accept-process-output process)) + (if stringp + guile-eval-result + (car (read-from-string guile-eval-result))))) + +(defun scheme-set-runlight (runlight) + (setq inferior-scheme-mode-line-process + (or runlight "no process")) + (setq scheme-last-runlight runlight) + (if guile-show-runlight-in-scheme-mode + (let ((old-buffer (current-buffer)) + (buffers inferior-scheme-associated-buffers)) + (unwind-protect + (while buffers + (set-buffer (car buffers)) + (setq scheme-mode-line-process runlight) + (setq buffers (cdr buffers))) + (set-buffer old-buffer)))) + (force-mode-line-update t)) + +(defconst scheme-runlight:running "eval" + "The character displayed when the Scheme process is running.") + +(defconst scheme-runlight:input "ready" + "The character displayed when the Scheme process is waiting for input.") + +(defconst scheme-runlight:read "input" + "The character displayed when the Scheme process is waiting for input.") + +(defconst scheme-runlight:load "loading" + "The character displayed when the Scheme process is loading forms.") + +(defvar guile-last-output-end) + +(setq count 0) +(defun scheme-enter-input-wait () + (scheme-set-runlight scheme-runlight:input) + (setq scheme-running-p nil) + (setq scheme-ready-p t) + (setq count (1+ count)) + ;(insert-before-markers (format "#%d\n" count)) + ;(setq n (1+ n) + ; l (append l (list (list n 'enter-input-wait)))) + (if comint-allow-output-p + (progn + (set-marker guile-last-output-end (point)) + (if (and guile-input-sent-p + ;; This code can be invoked multiple times + (or (not (marker-position guile-last-prompt-end)) + (/= (marker-position guile-last-prompt-end) + (point)))) + (progn + (setq guile-input-sent-p nil) + (set-marker guile-last-prompt-end (point)))))) + (setq comint-allow-output-p t) + (run-hooks 'scheme-enter-input-wait-hook)) + +(defun guile-on-error () + (setq guile-input-sent-p t) ;*fixme* + (if comint-allow-output-p + (progn + (goto-char (point-max)) + (if (not (zerop (current-column))) + (insert "\n")) + (set-marker (process-mark (get-buffer-process scheme-buffer)) + (point))))) + +(defun scheme-exit-input-wait () + (scheme-set-runlight scheme-runlight:running) + (setq scheme-ready-p nil) + (setq scheme-running-p t)) + +(defun scheme-enter-read () + (scheme-set-runlight scheme-runlight:read) + (setq scheme-ready-p nil) + (setq scheme-running-p nil)) + +(defun scheme-enter-load () + (scheme-set-runlight scheme-runlight:load) + (setq scheme-ready-p nil) + (setq scheme-load-p t)) + +(defun scheme-load-acknowledge () + (setq scheme-load-p nil)) + +;;; Error reporting and backtrace +;;; +(defvar guile-error-p nil) + +(defvar guile-last-displayed-position nil) + +(defvar guile-positional-reliability nil) + +(defvar guile-last-erring-overlay nil) + +(defvar guile-sexp-overlay nil) + +(defvar guile-frame-overlay nil) + +;(defconst guile-position-regexp +; " at line \\([0-9]+\\), column \\([0-9]+\\) in file \\(.+\\):$") +(defconst guile-position-regexp + "^\\(.+\\):\\([0-9]+\\):\\([0-9]+\\): ") + +(defconst guile-position-regexp-line 2) +(defconst guile-position-regexp-column 3) +(defconst guile-position-regexp-filename 1) + +(defvar guile-error-width 0) +(defvar guile-backtrace-length nil) +(defvar guile-backtrace-width 0) + +(defvar guile-error-map nil) +(if guile-error-map + nil + (setq guile-error-map ;(copy-keymap global-map) copies menus too... + (cons 'keymap (copy-sequence (nth 1 global-map)))) + (suppress-keymap guile-error-map) + (define-key guile-error-map "\e" 'guile-exit-debug) + (define-key guile-error-map "e" 'guile-frame-eval) + (define-key guile-error-map "q" 'guile-exit-debug) + ;; The following line is included since `local-map' doesn't seem to work. + (define-key guile-error-map [mouse-2] 'guile-select-stackframe) + (define-key guile-error-map [S-mouse-2] 'guile-frame-eval-at-click) + ) + +(defvar guile-stack-frame-map nil) +(if guile-stack-frame-map + nil + (setq guile-stack-frame-map (copy-list guile-error-map)) + (fset 'guile-stack-frame-map guile-stack-frame-map) ;*fixme* + (define-key guile-stack-frame-map [mouse-2] 'guile-select-stackframe) + ) + +(setplist 'guile-backtrace-button + (list 'mouse-face guile-backtrace-mouse-face + 'local-map 'guile-stack-frame-map)) + +(defun guile-exit-debug () + (interactive) + (if (eq (selected-frame) guile-error-frame) + (iconify-frame) + (if guile-sexp-overlay + (delete-overlay guile-sexp-overlay)) + (delete-other-windows (frame-first-window))) + (guile-unselect-stackframe)) + +(setq guile-backtrace-received-p nil) ;*fixme* + +(defun guile-receive-backtrace (buffer) + (let ((backtrace (get-buffer-create guile-backtrace-buffer-name))) + (save-excursion + (set-buffer backtrace) + (toggle-read-only 0) + (erase-buffer) + (insert-buffer-substring buffer) + (kill-buffer buffer) + (use-local-map guile-error-map) + (toggle-read-only 1) + (setq truncate-lines t) + (setq guile-backtrace-received-p t)))) ;*fixme* + +(defun guile-prep-backtrace () + (guile-unselect-stackframe) + (let ((buffer (get-buffer-create guile-backtrace-buffer-name))) + (and guile-got-backtrace-p ;*fixme* + (save-excursion + (set-buffer buffer) + (set-syntax-table scheme-mode-syntax-table) + (toggle-read-only 0) + (goto-char (point-max)) + (delete-backward-char 1) + (goto-char (point-min)) + ;; Parse + (save-match-data + (if (not (looking-at "\\(.\\|\n\\)*Backtrace:\n")) + nil + (replace-match "") + (let ((beg (point)) + (width 0) + (len 0)) + (while (not (eobp)) + (forward-line 1) + (let ((o (make-overlay beg (point)))) ;(1- (point)) + (overlay-put o 'category 'guile-backtrace-button) + (overlay-put o 'frame-number-pos beg)) + (setq width (- (point) beg 1)) + (if (> width guile-backtrace-width) + (setq guile-backtrace-width width)) + (setq beg (point)) + (setq len (1+ len))) + (setq guile-backtrace-length len)))) + (toggle-read-only 1))) + buffer)) + +(defvar guile-selected-frame nil) + +(defun guile-select-stackframe (click) + (interactive "e") + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (let* ((frame (save-excursion + (mouse-set-point click) + (goto-char (get-char-property (point) 'frame-number-pos)) + (guile-place-frame-overlay) + (let ((start (point))) + (skip-chars-forward " ") + (skip-chars-forward "0-9") + (if (= (char-after) ?:) + ;; new backtrace format + (progn + (forward-char) + (skip-chars-forward " ") + (setq start (point)) + (skip-chars-forward "0-9"))) + (string-to-number (buffer-substring-no-properties start (point)))))) + (oldpos (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-select-frame ,frame)))) + (pos (and oldpos (list (nth 0 oldpos) + (1+ (nth 1 oldpos)) ;Increment line number + (nth 2 oldpos))))) + (setq guile-selected-frame frame) + (cond (pos (if guile-source-window ;This is just insane *fixme* + (apply 'guile-display-scheme-sexp + (append pos (list guile-source-window t))) + (guile-display-error (get-buffer guile-error-buffer-name) + (get-buffer guile-backtrace-buffer-name) + pos))) + (guile-no-stack-p (message "No stack.")) + (guile-no-source-p (message "No source."))))) + +(defun guile-unselect-stackframe () + (guile-turn-off-frame-overlay) + (setq guile-selected-frame nil)) + +(defun guile-frame-eval (string) + (interactive "sEval: ") + (if (not guile-selected-frame) + (message "No frame selected.") + (setq guile-no-stack-p nil) + (setq guile-no-source-p nil) + (let ((res (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-frame-eval ,guile-selected-frame + ,string))))) + (cond (guile-no-stack-p (message "No stack.")) + (guile-no-source-p (message "No source.")) + ((eq (car res) 'result) (message "%s = %s" string (cadr res))) + (t (message "%s" (cadr res))))))) + +(defun guile-frame-eval-at-click (click) + (interactive "e") + (save-excursion + (mouse-set-point click) + (forward-sexp) + (let ((end (point))) + (backward-sexp) + (guile-frame-eval (buffer-substring-no-properties (point) end))))) + +(defun guile-receive-error (buffer) + (guile-on-error) + (setq guile-got-backtrace-p guile-backtrace-received-p) + (setq guile-backtrace-received-p nil) ;*fixme* + (setq guile-error-p t) + (let ((errbuf (get-buffer-create guile-error-buffer-name))) + (save-excursion + (set-buffer errbuf) + (toggle-read-only 0) + (erase-buffer) + (insert-buffer-substring buffer) + (kill-buffer buffer) + (use-local-map guile-error-map) + (toggle-read-only 1) + (setq guile-error-width 0) + (goto-char (point-min)) + (let ((beg (point)) + (width 0)) + (while (not (eobp)) + (forward-line 1) + (setq width (- (point) beg 1)) + (if (> width guile-error-width) + (setq guile-error-width width)) + (setq beg (point)))) + (setq guile-backtrace-width guile-error-width) + (guile-display-error errbuf (guile-prep-backtrace))))) + +(defvar guile-source-window nil) + +(defun guile-display-error (errbuf backbuf &optional pos) + (set-buffer errbuf) + (setq guile-source-window nil) + (let* ((errbuf-len (progn + (goto-char (point-max)) + (1- (guile-current-line)))) + (selected-window (selected-window)) + (mini-window nil) + (window + (if pos + (apply 'guile-display-scheme-sexp pos) + (and (progn + (goto-char (point-min)) + (re-search-forward guile-position-regexp nil t)) + (save-match-data + (guile-display-scheme-sexp + (car (read-from-string + (concat "\"" + (match-string guile-position-regexp-filename) + "\""))) + (string-to-number (match-string guile-position-regexp-line)) + (1- (string-to-number (match-string guile-position-regexp-column)))))))) + (errbuf-lines + (min (+ errbuf-len + (* 2 (/ guile-error-width + (if window + (window-width window) + guile-backtrace-max-width)))) + ;;In case we get big error messages + (/ guile-backtrace-max-height 2))) + (total-height + (if guile-got-backtrace-p + (min (max (+ guile-backtrace-length errbuf-lines 2) + guile-backtrace-min-height) + guile-backtrace-max-height) + (+ errbuf-lines 1)))) + (if (and window guile-backtrace-in-source-window) + (progn + (set-buffer errbuf) ;*fixme* This is awkward... + (or pos + (let ((inhibit-read-only t)) + (replace-match "") + (re-search-forward guile-position-regexp nil t) + (replace-match ""))) + (setq guile-source-window window) ;*fixme* + (and (frame-live-p guile-error-frame) + (make-frame-invisible guile-error-frame)) + (let* ((window-min-height 2) + (size (max (- (window-height window) total-height) + (/ (window-height window) 2))) + (new-window (split-window window size))) + (set-buffer (window-buffer window)) + (goto-char guile-last-displayed-position) + (guile-safe-forward-sexp) + (recenter (/ size 2)) + (setq x errbuf-lines) + (guile-display-buffers errbuf (1+ errbuf-lines) backbuf new-window + pos))) + (setq guile-source-window nil) + (guile-display-buffers + errbuf (1+ errbuf-lines) backbuf + (setq mini-window + (guile-get-create-error-window + total-height + (+ (min (max guile-backtrace-width + guile-backtrace-min-width) + guile-backtrace-max-width) + 2))) + pos)) + (cond ((window-live-p selected-window) + (select-window selected-window)) + ((window-live-p window) + (select-window window)) + ((window-live-p mini-window) + (select-window mini-window))) + ;; Warn if unreliable position + (if (and window (not guile-positional-reliability)) + (message "Warning: Couldn't reliably locate erring expression.")) + )) + +(defun guile-display-buffers (buffer1 split buffer2 window no-ding) + "Display BUFFER1 and BUFFER2 in WINDOW and raise the containing frame. +Display BUFFER1 and BUFFER2 in two windows obtained by splitting WINDOW +and ring the bell. Make sure that the whole contents of BUFFER1 and the +lower part of BUFFER2 will be visible. Also delete all other windows +displaying the buffers." + ;; Delete other windows displaying the buffers + (or (not window-system) (delete-windows-on buffer1)) ; *fixme* + (delete-windows-on buffer2) + ;; Split the window + (let ((lower-window + (and guile-got-backtrace-p + (let ((window-min-height 2) ;; Parameter to split-window + ) + (split-window window split))))) + ;; Contents + (set-window-buffer window buffer1) + (and guile-got-backtrace-p + (set-window-buffer lower-window buffer2)) + ;; Look + (set-window-start window 1) + (if guile-got-backtrace-p + (progn + (let ((pos (save-excursion + (set-buffer buffer2) + (goto-char (point-max)) + (forward-line -1) + (point)))) + (set-window-point lower-window pos)) + (select-window lower-window) + (recenter -1))) + ;; Raise frame + (make-frame-visible (window-frame window)) + (raise-frame (window-frame window)) + ;; Beep + (or no-ding (ding)) + )) + +(defvar guile-error-frame nil) + +(defun guile-get-create-error-window (height width) + (if window-system + (progn + (if (frame-live-p guile-error-frame) + (set-frame-size guile-error-frame width height) + (setq guile-error-frame (make-frame (list (cons 'height height) + (cons 'width width) + '(minibuffer . nil) + '(menu-bar-lines . 0))))) + (let ((window (frame-first-window guile-error-frame))) + (delete-other-windows window) + window)) + (let ((window (get-buffer-window (pop-to-buffer guile-error-buffer-name)))) + (sit-for 0) ; necessary because of an Emacs bug + window))) + +(defun guile-display-scheme-sexp (filename line column &optional swindow no-error-p) + (let ((finfo (scheme-virtual-file-list-find filename))) + (if finfo + (guile-display-sexp finfo line column swindow no-error-p) + (if (stringp filename) + (let ((buffer (guile-get-file-buffer filename))) + (if buffer + (if (and (guile-attachedp buffer) + (not guile-known-by-scheme)) + (progn + ;(ding) ; We shouldn't generate errors inside a filter. + ;(message "Internal data structures corrupt: guile-display-scheme-sexp") + (error "Internal data structures corrupt: guile-display-scheme-sexp")) + (if (and (not scheme-buffer-modified-p) + (not (buffer-modified-p buffer))) + ;; Take a chance and let's hope the file looks + ;; like it did when scheme saw it... + (progn + (if guile-auto-attach + (guile-attach-buffer buffer t) + ;*fixme* + (guile-dont-attach-buffer buffer t)) + (guile-display-scheme-sexp + (guile-buffer-file-name buffer) line column swindow no-error-p)) + nil ; Can't trust this one... + )) + (if (guile-file-readable-p filename) + (let ((guile-known-by-scheme t)) + (let ((buffer (guile-find-file-noselect filename))) + (if guile-auto-attach + (guile-attach-buffer buffer t) + ;*fixme* + (guile-dont-attach-buffer buffer t)) + (guile-display-scheme-sexp + (guile-buffer-file-name buffer) + line column swindow no-error-p))) + (ding) + (message "Couldn't find the erring file.") + nil))))))) + +(defun guile-file-readable-p (filename) + (save-excursion + (set-buffer scheme-buffer) + (file-readable-p filename))) + +(defun guile-find-file-noselect (filename) + (save-excursion + (set-buffer scheme-buffer) + (find-file-noselect filename))) + +(defun guile-display-sexp (finfo line column &optional swindow no-error-p) + ;; Returns the window containing the displayed sexp + (let ((overlay-list (cdr finfo)) + (overlay nil)) + ;; Select an overlay candidate + (while overlay-list + (if (not (overlay-get (car overlay-list) 'original-line)) + (setq overlay-list (cdr overlay-list)) + (if (>= line (overlay-get (car overlay-list) 'original-line)) + (progn + (setq overlay (car overlay-list)) + (setq overlay-list nil)) + (setq overlay-list (cdr overlay-list))))) + (let ((buffer (and overlay (overlay-buffer overlay)))) + (if buffer + (progn + (set-buffer buffer) + (guile-goto-position line column overlay) + (if (< (point) (overlay-end overlay)) + (progn + (setq guile-positional-reliability + (not (overlay-get overlay 'modifiedp))) + (if (not (eq (char-syntax (following-char)) ?\()) + (progn + (setq guile-positional-reliability nil) + (goto-char (overlay-start overlay)))) + (setq guile-last-erring-overlay overlay) + (guile-display-sexp-at-point swindow no-error-p)))))))) + +(defun guile-display-sexp-at-point (&optional swindow no-error-p) + "Move sexp overlay to sexp at point and display window. +Returns the displayed window." + (let ((start (point)) + (end nil)) + (save-excursion + (setq end + (if (guile-safe-forward-sexp) + (point) + (goto-char (1+ start)) + (if (re-search-forward "^\\((\\|$\\)" nil t) + (1- (match-beginning 0)) + (point-max))))) + (if (overlayp guile-sexp-overlay) + (move-overlay guile-sexp-overlay start end (current-buffer)) + (setq guile-sexp-overlay (make-overlay start end)) + (overlay-put guile-sexp-overlay 'category 'guile-error-sexp)) + (if (window-live-p swindow) + (set-window-buffer swindow (current-buffer))) + (guile-display-position start nil swindow no-error-p))) + +(setplist 'guile-error-sexp + (list 'face guile-error-face + 'evaporate t + 'modification-hooks '(guile-turn-off-sexp-overlay) + 'insert-behind-hooks '(guile-turn-off-sexp-overlay))) + +(setplist 'guile-stack-frame + (list 'face guile-error-face + 'mouse-face guile-error-face + 'evaporate t + 'modification-hooks '(guile-turn-off-frame-overlay) + 'insert-behind-hooks '(guile-turn-off-frame-overlay))) + +(defun guile-place-frame-overlay () + (let ((end (save-excursion (forward-line) (point)))) + (if (and guile-frame-overlay (overlayp guile-frame-overlay)) + (move-overlay guile-frame-overlay (point) end) + (setq guile-frame-overlay (make-overlay (point) end))) + (overlay-put guile-frame-overlay 'category 'guile-stack-frame))) + +(defun guile-turn-off-sexp-overlay (&rest args) + (cond (guile-sexp-overlay (delete-overlay guile-sexp-overlay)) + ;; For stability. + ((overlayp (car args)) (delete-overlay (car args))))) + +(defun guile-turn-off-frame-overlay (&rest args) + (cond (guile-frame-overlay (delete-overlay guile-frame-overlay)) + ;; For stability. + ((overlayp (car args)) (delete-overlay (car args))))) + +(defun guile-display-position (pos &optional buffer swindow no-delete-p) + "Display position POS in BUFFER. +If BUFFER is omitted, the current buffer is used. +Returns the displaying window." + (let ((buffer (or buffer (current-buffer)))) + (set-buffer buffer) + (let ((window (or (and (window-live-p swindow) swindow) + (get-buffer-window buffer t) + (if (frame-live-p guile-error-frame) + (delete-frame guile-error-frame)) + (display-buffer buffer)))) + (or no-delete-p + (delete-other-windows window)) + (select-window window) + (goto-char pos) + (setq guile-last-displayed-position pos) + window))) + +(defun guile-goto-position (line column overlay) + (goto-char (overlay-start overlay)) + (forward-line (- line (overlay-get overlay 'original-line))) + (move-to-column column)) + + +;;; Scheme process associated buffers +;;; + +;; This function must be fixed to handle rel/absol filenames +(defun guile-get-file-buffer (filename) + (get-file-buffer filename)) + +(defun guile-attachedp (&optional buffer) + (if buffer + (save-excursion + (set-buffer buffer) + scheme-associated-process-buffer) + scheme-associated-process-buffer)) + +(defun guile-attach-buffer (buffer &optional known-by-scheme) + "Put the buffer in enhanced editing mode and attach it to the scheme +process: load it into scheme, and make sure to send any changes to it +hereafter to scheme at synchronization points." + (interactive (list (current-buffer))) + (if (memq buffer inferior-scheme-associated-buffers) + (error "Scheme buffer already attached!")) + (if (not (guile-enhancedp buffer)) + (guile-enhanced-edit buffer known-by-scheme)) + (save-excursion + (set-buffer scheme-buffer) + (setq inferior-scheme-associated-buffers + (cons buffer + inferior-scheme-associated-buffers)) + (set-buffer buffer) + (setq scheme-associated-process-buffer scheme-buffer) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process "attached")) + ;; Now link it to the scheme process + (if (and (guile-buffer-file-name) + (not (guile-virtually-linked-p (guile-buffer-file-name)))) + (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) + ;; And sync. + (if (not known-by-scheme) + (progn + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t) + (setq guile-synchronizedp nil) + (guile-sync-with-scheme)))) + ;; Rebuild menus... + (force-mode-line-update)) + +;;*fixme* +(defun guile-dont-attach-buffer (buffer &optional known-by-scheme) + "Put the buffer in enhanced editing mode and attach it to the scheme +process: load it into scheme, and make sure to send any changes to it +hereafter to scheme at synchronization points." + (interactive (list (current-buffer))) + (if (memq buffer inferior-scheme-associated-buffers) + (error "Scheme buffer already attached!")) + (if (not (guile-enhancedp buffer)) + (guile-enhanced-edit buffer known-by-scheme)) + (save-excursion +; (set-buffer scheme-buffer) +; (setq inferior-scheme-associated-buffers +; (cons buffer +; inferior-scheme-associated-buffers)) + (set-buffer buffer) +; (setq scheme-associated-process-buffer scheme-buffer) == attach +; (if (not guile-show-runlight-in-scheme-mode) +; (setq scheme-mode-line-process "attached")) + ;; Now link it to the scheme process + (if (guile-buffer-file-name) + (guile-virtual-link (guile-buffer-file-name) scheme-buffer-overlays)) + ;; And sync. + (if (not known-by-scheme) + (progn + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t) + (setq guile-synchronizedp nil) + ;(guile-sync-with-scheme) + ))) + ;; Rebuild menus... + (force-mode-line-update)) + +(defun guile-detach-buffer (buffer) + "Disconnect the buffer from the scheme process." + (interactive (list (current-buffer))) + (save-excursion + (set-buffer buffer) + ;; Unlink any virtual overlay files associated with the buffer... + ;(let ((overlays scheme-buffer-overlays)) + ; (while overlays + ; (if (guile-virtual-p (car overlays)) + ; (scheme-virtual-unlink (overlay-get (car overlays) 'id))) + ; (setq overlays (cdr overlays)))) + (setq scheme-associated-process-buffer nil) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process nil)) + (set-buffer scheme-buffer) + (setq inferior-scheme-associated-buffers + (delq buffer + inferior-scheme-associated-buffers)) + ;(scheme-virtual-unlink (guile-buffer-file-name buffer)) + ) + (force-mode-line-update)) + +(defun guile-detach-all () + "Disconnect all buffers from the scheme process." + (interactive) + (save-excursion + (set-buffer scheme-buffer) + (while inferior-scheme-associated-buffers + ;; Is it alive? + (if (buffer-name (car inferior-scheme-associated-buffers)) + (save-excursion + (set-buffer (car inferior-scheme-associated-buffers)) + (setq scheme-associated-process-buffer nil) + (if (not guile-show-runlight-in-scheme-mode) + (setq scheme-mode-line-process nil)))) + (setq inferior-scheme-associated-buffers + (cdr inferior-scheme-associated-buffers))))) + +;;; Linkage of files to scheme space +;;; +(defvar scheme-virtual-file-list '()) + +(defun scheme-virtual-file-list-find (name) + (let ((name (file-truename name))) + (assoc name scheme-virtual-file-list))) + +(defun guile-buffer-file-name (&optional buffer) + (let ((name (buffer-file-name buffer))) + (and name + (file-truename name)))) + +(defvar guile-synchronizedp t) + +(defvar guile-last-virtual-id 0) + +(defun guile-synchronizedp () + guile-synchronizedp) + +;;*fixme* +(defun guile-alloc-virtual-id (overlay) + (let ((n (setq guile-last-virtual-id (1+ guile-last-virtual-id)))) + (let* ((buffer (overlay-buffer overlay)) + (name (or (guile-buffer-file-name buffer) + (buffer-name buffer)))) + (format "%s(%d)" name n)))) + +(defun guile-virtual-p (overlay) + (overlay-get overlay 'virtualp)) + +(defun guile-virtually-linked-p (name) + (scheme-virtual-file-list-find name)) + +(defun guile-virtual-link (name overlay-list) + (let ((finfo (scheme-virtual-file-list-find name))) + (if finfo + (progn + (guile-kill-overlays (cdr finfo)) + (setcdr finfo (copy-sequence overlay-list))) + (setq scheme-virtual-file-list + (cons (cons name + (copy-sequence overlay-list)) + scheme-virtual-file-list))))) + +(defun scheme-virtual-unlink (name) + (let ((finfo (scheme-virtual-file-list-find name))) + (if finfo + (setq scheme-virtual-file-list + (delq finfo scheme-virtual-file-list))))) + +(defun guile-load-file (filename) + "Load a Scheme file into the inferior Scheme process." + (interactive (comint-get-source "Load Scheme file: " scheme-prev-l/c-dir/file + scheme-source-modes t)) ; T because LOAD + ; needs an exact name + (if (not scheme-ready-p) + (error "Scheme not ready.")) + (comint-check-source filename) ; Check to see if buffer needs to be saved. + (setq scheme-prev-l/c-dir/file (cons (file-name-directory filename) + (file-name-nondirectory filename))) + (let ((old-buffer (current-buffer))) + (set-buffer scheme-buffer) + (setq comint-allow-output-p nil) + (setq guile-unallowed-output nil) + (set-buffer old-buffer)) + (scheme-set-runlight scheme-runlight:load) + (setq scheme-ready-p nil) + (comint-send-string (scheme-proc) (concat "(load \"" + filename + "\"\)\n")) + ;; Syncronize... + (while (not scheme-ready-p) + (accept-process-output (scheme-proc) 0 guile-process-timeout)) + ) + +(defun guile-reread-buffer (buffer) + "Make the scheme interpreter read the buffer contents again." + (interactive (list (current-buffer))) + (if (not scheme-ready-p) + (error "Scheme not ready.")) + (save-excursion + (set-buffer buffer) + (for-each (function (lambda (overlay) + (overlay-put overlay 'modifiedp t))) + scheme-buffer-overlays) + (setq scheme-buffer-modified-p t)) + (setq guile-synchronizedp nil) + (guile-sync-with-scheme)) + +(defun guile-get-associated-buffers () + (save-excursion + (set-buffer scheme-buffer) + inferior-scheme-associated-buffers)) + +(defvar guile-symclash-obarray (make-vector guile-symclash-obarray-size 0)) + +(defun guile-reset-symclash-obarray () + (mapatoms (function makunbound) guile-symclash-obarray)) + +(defvar guile-displayed-erring-buffers nil) +(defvar guile-quiet t) + +(defun guile-check-all () + (interactive) + (setq guile-quiet t) + (guile-check-all-1)) + +(defun guile-check-all-1 () + (guile-show-check-error + (catch 'erroneous-overlay + (guile-reset-symclash-obarray) + (if (not (and guile-last-displayed-erring-overlay + (eq (overlay-buffer guile-last-displayed-erring-overlay) + (current-buffer)))) + (progn + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil))) + (for-each (function (lambda (buffer) + (guile-check-buffer-1 buffer) + (setq guile-displayed-erring-buffers + (cons buffer + guile-displayed-erring-buffers)))) + (let ((ls (guile-get-enhanced-buffers)) + (rem guile-displayed-erring-buffers)) + (while rem + (setq ls (delq (car rem) ls)) + (setq rem (cdr rem))) + ls)) + nil))) + +(defun guile-check-buffer (buffer) + (interactive (list (current-buffer))) + (guile-show-check-error + (catch 'erroneous-overlay + (save-excursion + (guile-reset-symclash-obarray) + (guile-check-buffer-1 buffer) + ;(set-buffer old-buffer) + nil)))) + +(defun guile-show-check-error (oinfo) + (if (not oinfo) + (progn + (if guile-last-displayed-erring-overlay + (message "No more errors found among buffers in enhanced editing mode!") + (message "No errors found among buffers in enhanced editing mode!")) + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil) + t) + (setq guile-last-displayed-erring-overlay (car oinfo)) + (set-buffer (overlay-buffer (car oinfo))) + (goto-char (overlay-start (car oinfo))) + (if (not guile-quiet) + (ding)) + (guile-display-sexp-at-point) + (recenter) + (message "%s" (cdr oinfo)) + nil)) + +(defvar guile-last-displayed-erring-overlay nil) + +(defun guile-check-buffer-1 (buffer) + (set-buffer buffer) + (save-excursion + (for-each (function guile-check-overlay) + (let* ((ls (reverse scheme-buffer-overlays)) + (tail (memq guile-last-displayed-erring-overlay ls))) + (if tail + (cdr tail) + ls))))) + +(defconst guile-defexpr "(\\(define\\|defmacro\\)[^ \t\n()]*[ \t\n]+(*\\([^ \t\n()]+\\)") +(defconst guile-defexpr-name 2) + +(defun guile-check-overlay (overlay) + (if (overlay-get overlay 'brokenp) + (throw 'erroneous-overlay + (cons overlay "Bad expression.")) + (goto-char (overlay-start overlay)) + (if (looking-at guile-defexpr) + (let ((sym (intern (match-string guile-defexpr-name) + guile-symclash-obarray))) + (if (boundp sym) + (let* ((overlay1 (symbol-value sym)) + (buffer (overlay-buffer overlay1)) + (line (save-excursion + (set-buffer buffer) + (save-excursion + (goto-char (overlay-start overlay1)) + (guile-current-line))))) + (throw 'erroneous-overlay + (cons overlay + (format "Symbol \"%s\" already defined in %s, line %d." + sym + (file-name-nondirectory + (or (guile-buffer-file-name buffer) + (buffer-name buffer))) + line)))) + (set sym overlay)))))) + +(defun guile-sync-with-scheme () + (interactive) + (if (and (not guile-synchronizedp) + scheme-ready-p) + (progn + (setq guile-error-p nil) + (setq guile-last-erring-overlay nil) + (catch 'exit + (for-each (function guile-sync-buffer-1) + (guile-get-associated-buffers)) + (setq guile-synchronizedp t)) + (if guile-last-erring-overlay + (progn + (overlay-put guile-last-erring-overlay 'brokenp t) + (overlay-put guile-last-erring-overlay + 'face guile-broken-face) + (if guile-show-overlays-p + (save-excursion + (set-buffer (overlay-buffer guile-last-erring-overlay)) + (guile-show-overlays)))))))) + +(defun guile-sync-buffer (buffer) + (interactive (list (current-buffer))) + (catch 'exit + (guile-sync-buffer-1 buffer))) + +(defun guile-sync-buffer-1 (buffer) + (save-excursion + (set-buffer buffer) + (if scheme-buffer-modified-p + (progn + ;; Can we do it by loading the file again? + (if (and (not (buffer-modified-p buffer)) + (file-readable-p (guile-buffer-file-name)) + (not (let ((overlays scheme-buffer-overlays)) + (while (and overlays + (not (overlay-get (car overlays) 'brokenp))) + (goto-char (overlay-start (car overlays))) + (overlay-put (car overlays) 'original-line + (guile-current-line)) ; non-optimal *fixme* + (setq overlays (cdr overlays))) + overlays))) + (progn + (guile-load-file (guile-buffer-file-name)) + (if guile-error-p + (progn + (throw 'exit nil))) + (let ((overlays scheme-buffer-overlays)) + (while overlays + (overlay-put (car overlays) 'modifiedp nil) + (setq overlays (cdr overlays))))) + ;; No - we have to send the overlays separately from top to bottom + (let ((overlays (reverse scheme-buffer-overlays))) + (if (or (= (point-min) (point-max)) + (not (eq (char-syntax (char-after (point-min))) ?\())) + (setq overlays (cdr overlays))) + (while overlays + (if (and (overlay-get (car overlays) 'modifiedp) + (not (overlay-get (car overlays) 'brokenp))) + (progn + (guile-send-overlay (guile-alloc-finfo (car overlays))) + (if guile-error-p (throw 'exit nil)))) + (setq overlays (cdr overlays))))) + (setq scheme-buffer-modified-p nil))) + (if guile-show-overlays-p + (guile-show-overlays)))) + +(defun guile-alloc-finfo (overlay) + (if (not (overlay-get overlay 'id)) + (progn + (let ((finfo (scheme-virtual-file-list-find (guile-buffer-file-name)))) + (if finfo + (setcdr finfo (delq overlay (cdr finfo))))) + (guile-new-finfo overlay)) + (let ((finfo (assq (overlay-get overlay 'id) + scheme-virtual-file-list))) + (if finfo + (let ((id (guile-alloc-virtual-id overlay))) + (setcar finfo id) + (overlay-put overlay 'id id) + (overlay-put overlay 'virtualp t) + finfo) + (guile-new-finfo overlay))))) + +(defun guile-new-finfo (overlay) + (let* ((id (guile-alloc-virtual-id overlay)) + (finfo (cons id (list overlay)))) + (overlay-put overlay 'id id) + (overlay-put overlay 'virtualp t) + (goto-char (overlay-start overlay)) + (overlay-put overlay 'original-line (guile-current-line)) + (setq scheme-virtual-file-list + (cons finfo scheme-virtual-file-list)) + finfo)) + +(defvar guile-last-prompt-end nil) +(defvar guile-input-sent-p t) + +(defun guile-send-input () + (interactive) + (if (and (marker-position guile-last-prompt-end) + scheme-ready-p) + (let ((start (save-excursion + (goto-char (point-max)) + (and (guile-real-safe-backward-sexp) + (point))))) + (if (not (and start + (<= (marker-position guile-last-prompt-end) start) + (guile-whitespace-between-p guile-last-prompt-end + start))) + (progn + (insert "\n") + (put-text-property (1- (point)) (point) 'face 'bold)) + (goto-char (point-max)) + (comint-send-input) + (setq guile-input-sent-p t))) + (comint-send-input))) + +(defconst guile-whitespace-chars " \t\n\r\f") + +(defun guile-whitespace-between-p (beg end) + (let ((beg (if (markerp beg) (marker-position beg) beg)) + (end (if (markerp end) (marker-position end) end))) + (if (> beg end) + (let ((swap beg)) + (setq beg end end swap))) + (save-excursion + (goto-char beg) + (skip-chars-forward guile-whitespace-chars end) + (= (point) end)))) + +;;*fixme* This is redundant code. Compare sync. +(defun guile-send-changes () + (interactive) + (setq guile-last-displayed-erring-overlay nil) + (setq guile-displayed-erring-buffers nil) + (setq guile-quiet nil) + (if (guile-check-all-1) + (progn + (setq guile-error-p nil) + (catch 'exit + (let ((old-buffer (current-buffer))) + (for-each (function + (lambda (buffer) + (set-buffer buffer) + (save-excursion + (goto-char (point-max)) + (let ((end (point))) + (beginning-of-buffer) + (guile-send-region (point) end nil t))) + (if guile-show-overlays-p + (guile-show-overlays)))) + (guile-get-enhanced-buffers)) + (set-buffer old-buffer)))))) + +(defun scheme-send-region (start end) + "Send the current region to the inferior Scheme process." + (interactive "r") + (if (not (guile-enhancedp (current-buffer))) + (progn + (comint-send-region (scheme-proc) start end) + (comint-send-string (scheme-proc) "\n")) + (setq guile-error-p nil) + (catch 'exit + (guile-send-region start end t) + (cond (guile-define-header-emitted-p + (message "Defined.")) + (guile-last-result + (guile-insert-before-prompt + (concat "RESULT: " guile-last-result "\n")) + (message "%s" (concat "Result: " guile-last-result))))) + (if guile-show-overlays-p + (guile-show-overlays)))) + +(defvar guile-define-name-marker) + +(defun guile-insert-before-prompt (string) + (save-excursion + (set-buffer scheme-buffer) + (save-excursion + (goto-char guile-last-prompt-end) + (forward-line 0) ;; ignore field boundary + (let ((inhibit-read-only t) + (before-prompt (point)) + (w (or (get-buffer-window scheme-buffer 'visible) + (get-buffer-window scheme-buffer t)))) + (let ((w-start (and w (window-start w)))) + (insert-before-markers string) + (if (and w (= before-prompt w-start)) + (let ((selected (selected-window))) + (unwind-protect + (progn + (select-window w) + (recenter)) + (select-window selected) + (set-buffer scheme-buffer))))))))) + +(defvar guile-define-header-emitted-p nil) +(defvar guile-define-startcol 0) +(defvar guile-define-filler "") +(defvar guile-define-fillcol 0) +(defvar guile-last-result nil) + +(defun guile-send-region (start end send-all-p &optional multip) + (if (not scheme-ready-p) + (error "Scheme is not ready to receive expressions from Emacs.")) + (let ((overlays (reverse scheme-buffer-overlays))) + (if (or (= (point-min) (point-max)) + (not (eq (char-syntax (char-after (point-min))) ?\())) + (setq overlays (cdr overlays))) + ;; First skip some overlays + (while (and overlays (<= (overlay-end (car overlays)) start)) + (setq overlays (cdr overlays))) + (setq guile-define-header-emitted-p nil) + (setq guile-last-result nil) + (let ((start (max start (overlay-start (car overlays))))) + (if (/= start (overlay-start (car overlays))) + (guile-send-overlay (save-excursion + (guile-alloc-finfo (car overlays))) + t + multip + start + end) + (while (and overlays + (< (overlay-start (car overlays)) end)) + (if (and (not (overlay-get (car overlays) 'brokenp)) + (or send-all-p + (overlay-get (car overlays) 'modifiedp))) + (guile-send-overlay (save-excursion + (guile-alloc-finfo (car overlays))) + t + multip)) + (setq overlays (cdr overlays))))))) + +(defconst guile-end-of-chunk "\001\n") + +;; *fixme* Improve code. +(defun guile-send-overlay (finfo &optional interactivep multip start end) + (let* ((filename (car finfo)) + (overlay (car (cdr finfo))) + (module-overlay (overlay-get overlay 'module-overlay)) + (module (or (and module-overlay + (overlay-get module-overlay 'define-module)) + "#f")) + (old-buffer (current-buffer)) + (old-pos (point))) + + ;; Define the module of the overlay if not done before + (if (and module-overlay + (overlay-get module-overlay 'modifiedp)) + (guile-send-overlay (save-excursion + (guile-alloc-finfo module-overlay)))) + + (set-buffer scheme-buffer) + ;; Inhibit process output and hamster it + (setq comint-allow-output-p nil) + (setq guile-eval-output nil) + (setq guile-unallowed-output "") + + (set-buffer old-buffer) + ;; Turn on runlight + (scheme-enter-load) + ;; Send load command + (comint-send-string + (scheme-proc) + (if start + (let ((column (save-excursion + (goto-char start) + (current-column)))) + (format "(%%%%emacs-load %S %d %d '%s #%c)\n" + filename + (+ (overlay-get overlay 'original-line) + -1 + (count-lines (overlay-get overlay 'original-line) + start) + (if (zerop column) 0 -1)) + column + module + (if interactivep ?t ?f))) + (format "(%%%%emacs-load %S %d %d '%s #%c)\n" + filename + (1- (overlay-get overlay 'original-line)) + 0 + module + (if interactivep ?t ?f)))) + ;; Send overlay contents + (comint-send-string + (scheme-proc) + (buffer-substring-no-properties (or start (overlay-start overlay)) + (or end (overlay-end overlay)))) + ;; If this is the last overlay we may have to send a final newline + ;;(if (and (eq overlay scheme-buffer-last-overlay) + ;; (/= (overlay-start overlay) + ;; (overlay-end overlay)) + ;; (not (eq (char-after (1- (overlay-end overlay))) ?\n))) + (comint-send-string (scheme-proc) "\n") + ;; Remove modified mark so that Emacs will trust its idea about positions. + (or start (overlay-put overlay 'modifiedp nil)) + ;; Send end-of-text + (comint-send-string (scheme-proc) guile-end-of-chunk) + ;; Wait for acknowledge. + (while (and scheme-load-p (not guile-error-p)) + (accept-process-output (scheme-proc) 0 guile-process-timeout)) + + ;; Have we received an error? + (if guile-error-p + (progn + (if interactivep + (save-excursion + (set-buffer scheme-buffer) + (let ((output guile-unallowed-output)) + (if (string-match "\\(^ABORT:.*\n\\)+" output) + (guile-insert-before-prompt (match-string 1 output)))))) + (overlay-put overlay 'modifiedp t) + (setq scheme-load-p nil) + (throw 'exit nil))) ;Abort whatever we was doing. + + ;; The transfer has been successful. Display defined symbol. + (if interactivep + (progn + (goto-char (overlay-start overlay)) + (if (and (not (and start (/= start (overlay-start overlay)))) + (looking-at guile-defexpr)) + (progn + (guile-display-name (match-string guile-defexpr-name) + multip) + (setq guile-last-result nil)) + (set-buffer scheme-buffer) + (if guile-eval-output + (guile-insert-before-prompt guile-eval-output)) + (setq guile-last-result guile-eval-result) + (set-buffer old-buffer)) + (goto-char old-pos) + (sit-for 0)) + + (goto-char old-pos)))) + +(defun guile-display-name (name multip) + (save-excursion + (let ((buffer-file (guile-buffer-file-name)) + (buffer-name (buffer-name))) + (set-buffer scheme-buffer) + (save-excursion + (let ((inhibit-read-only t)) + (if (not guile-define-header-emitted-p) + (let ((header + (format "DEFINED:%s ()\n" + (if multip + (concat " " + (or (and buffer-file + (file-name-nondirectory + buffer-file)) + buffer-name)) + "")))) + (guile-insert-before-prompt header) + (set-marker guile-define-name-marker + (save-excursion + (goto-char guile-last-prompt-end) + (forward-line 0) + (- (point) 2))) + (setq guile-define-startcol (- (length header) 2)) + (setq guile-define-filler + (concat "\n" + (make-string guile-define-startcol ? ))) + (setq guile-define-fillcol + (let ((window (get-buffer-window scheme-buffer t))) + (if window + (- (window-width window) 3) + fill-column))) + (setq guile-define-header-emitted-p t))) + (goto-char guile-define-name-marker) + (cond ((= (current-column) guile-define-startcol)) + ((> (+ (current-column) (length name)) guile-define-fillcol) + (insert-before-markers guile-define-filler)) + (t (insert-before-markers " "))) + (insert-before-markers name)))))) + +;;; Enhanced editing +;;; + +(defvar guile-n-enhanced-buffers 0 + "Number of buffers in enhanced edit mode.") + +(defun guile-enhancedp (&optional buffer) + (interactive) + (if (not buffer) + scheme-buffer-overlays + (save-excursion + (set-buffer buffer) + scheme-buffer-overlays))) + +(defun guile-get-enhanced-buffers () + (let ((ls (buffer-list)) + (ans '())) + (while ls + (if (guile-enhancedp (car ls)) + (setq ans (cons (car ls) ans))) + (setq ls (cdr ls))) + (reverse ans))) + +(defun guile-enhanced-edit (buffer &optional known-by-scheme) + "Put the current scheme buffer into enhanced editing mode." + (interactive (list (current-buffer))) + (if (guile-enhancedp buffer) + (error "Already in enhanced editing mode!")) + (save-excursion + (set-buffer buffer) + (guile-parse-buffer known-by-scheme) + (setq scheme-overlay-repair-function 'guile-repair-overlays) + (if (not (memq scheme-overlay-repair-idle-timer timer-idle-list)) + (setq scheme-overlay-repair-idle-timer + (run-with-idle-timer 0.1 t 'run-hook-with-args + 'scheme-overlay-repair-function))) + (setq guile-n-enhanced-buffers (1+ guile-n-enhanced-buffers))) + (force-mode-line-update)) + +(defun guile-normal-edit (buffer) + "Exit enhanced editing mode." + (interactive (list (current-buffer))) + (if (guile-attachedp) + (error "Can't exit enhanced editing mode while attached to scheme. Detach first.")) + (save-excursion + (set-buffer buffer) + (for-each (function (lambda (overlay) + (if (overlayp overlay) ; For stability's sake + (progn + (if (guile-virtual-p overlay) + (scheme-virtual-unlink (overlay-get overlay 'id))) + (delete-overlay overlay))))) + scheme-buffer-overlays) + (setq scheme-buffer-overlays ()) + (setq scheme-buffer-last-overlay nil) + ;; Since we let go of the control, we have to mark the buffer... + ;(setq scheme-buffer-modified-p t) Now using first-change-hook. + (setq scheme-overlay-repair-function nil) + (scheme-virtual-unlink (guile-buffer-file-name buffer)) + (setq guile-n-enhanced-buffers (1- guile-n-enhanced-buffers))) + (force-mode-line-update)) + +;;; Overlay lists +;;; +;;; Every non-broken overlay containing a sexp starts with a character +;;; with syntax ?\(. +;;; The first overlay in the overlay list is never broken. + +(defun guile-current-line () + (+ (count-lines 1 (point)) + (if (= (current-column) 0) 1 0))) + +(defun guile-safe-forward-sexp () + "Move point one sexp forwards. +Returns non-nil if no error was encountered." + (not (condition-case err + (forward-sexp) + (error err)))) + +(defun guile-safe-backward-sexp () + "Move point one sexp forwards. +Returns non-nil if no error was encountered." + (not (condition-case err + (backward-sexp) + (error err)))) + +(defun guile-real-safe-backward-sexp () + (and (guile-safe-backward-sexp) + (progn + (and (char-before) + (char-before (1- (point))) + (eq (char-before (1- (point))) ?#) + (eq (char-syntax (char-before)) ?w) + (forward-char -2)) + t))) + +(defun guile-parse-buffer (&optional initialp) + (interactive) + (if (= (point-min) (point-max)) + ;; Apparently, the buffer is empty + (progn + (setq overlay (make-overlay (point-min) (point-max) nil nil t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (overlay-put overlay 'insert-behind-hooks + '(rear-sticky-overlay-function guile-handle-modification)) + (setq scheme-buffer-overlays (list overlay)) + (setq scheme-buffer-last-overlay overlay)) + (setq scheme-buffer-last-overlay nil) + (guile-reparse-buffer nil (point-min) initialp) + (guile-modularize scheme-buffer-overlays))) + +(defvar guile-tail-cons (cons nil nil)) + +(defun guile-cons-before-match (x ls) + "Match X against successive elements of LS. +Return cons before the one with car matching X." + (if (or (null ls) + (eq (car ls) x)) + nil + (while (and (cdr ls) (not (eq (car (cdr ls)) x))) + (setq ls (cdr ls))) + (and (cdr ls) + ls))) + +;; Here I've sacrificed readability for speed... +;; Geeh! What a monstrum! +;; +(defun guile-reparse-buffer (start-overlay limit &optional initialp) + "Reparse buffer backwards to build/update `scheme-buffer-overlays'. +Start with overlay START-OVERLAY. Stop when we have passed LIMIT. +If START-OVERLAY is nil parsing starts from (point-max). +The optional third argument INITIALP should be non-nil if parsing +for the first time. This will cause initialization of the +original-line property." + (let* ((tailp (and start-overlay + (progn + (goto-char (overlay-end start-overlay)) + (if (bolp) + (guile-cons-before-match start-overlay + scheme-buffer-overlays) + (let ((after (guile-cons-before-match + start-overlay + scheme-buffer-overlays))) + (if after + (progn + (overlay-put (car after) 'brokenp t) + (guile-cons-before-match + after + scheme-buffer-overlays)))))))) + (tail (or tailp guile-tail-cons)) + (overlays (if tailp (cdr tail) scheme-buffer-overlays)) + (overlay nil) + (first-broken nil) + (last-broken nil) + (last-end (if tailp + (overlay-end (car (cdr tail))) + (point-max)))) + (goto-char last-end) + ;; Parse buffer backwards... + (save-match-data + (while (> (point) limit) + ;; First try to move one sexp backwards... + (if (and (guile-safe-backward-sexp) + (bolp)) + (progn + ;; Do we have it in the list? + (while (and overlays + (> (overlay-start (car overlays)) (point))) + ;; First throw away some trash overlays... + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + ;; It's a stand-alone sexp, remove it from the list + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + (if (and overlays + (= (overlay-start (car overlays)) (point))) + ;; Yes! + (progn ; Is it intact? + (if (or (overlay-get (car overlays) 'brokenp) + (/= (overlay-end (car overlays)) last-end)) + ;; No... + (progn + ;; Adjust it. + (move-overlay (car overlays) (point) last-end) + ;; Can we repair it? + (if (if (bobp) + (or (eolp) + (eq (char-syntax (following-char)) ?\() + (eq (char-syntax (following-char)) ?<) + (eq (char-syntax (following-char)) ? )) + (eq (char-syntax (following-char)) ?\()) + ;; Yes! + (progn + (overlay-put (car overlays) 'brokenp nil) + (overlay-put (car overlays) 'face nil) + (overlay-put (car overlays) 'modifiedp t) + (overlay-put (car overlays) + 'define-module + (and (looking-at "(define-module \\((.*)\\)") + (condition-case err + (save-excursion + (goto-char (match-beginning 1)) + (read (current-buffer))) + (error nil))))) + ;; No... + (overlay-put (car overlays) 'face guile-broken-face) + (overlay-put (car overlays) 'modifiedp t)))) + ;; Link it in. + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + ;; We probably have to make a new overlay... + ;; First check if it's OK. + (if (if (bobp) + (or (eolp) + (eq (char-syntax (following-char)) ?\() + (eq (char-syntax (following-char)) ?<) + (eq (char-syntax (following-char)) ? )) + (eq (char-syntax (following-char)) ?\()) + ;; Everything seems OK with this one. + (progn + (setq overlay (make-overlay (point) last-end nil nil t)) + (if initialp + (overlay-put overlay 'original-line + (guile-current-line)) + (overlay-put overlay 'modifiedp t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (overlay-put overlay + 'define-module + (and (looking-at "(define-module \\((.*)\\)") + (condition-case err + (save-excursion + (goto-char (match-beginning 1)) + (read (current-buffer))) + (error nil)))) + ;; And link it in... + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail))) + ;; But this one is broken! + ;; Try to find some structure... + (guile-backward-broken-sexp) + (while (and overlays + (> (overlay-start (car overlays)) (point))) + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + ;; Is it possibly the first one in the overlay list? + (if (and overlays + (= (overlay-start (car overlays)) (point))) + (progn + ;; Adjust it. + (move-overlay (car overlays) (point) last-end) + (overlay-put (car overlays) 'face guile-broken-face) + (overlay-put (car overlays) 'modifiedp t) + ;; Link it in. + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + ;; It wasn't - make a new overlay. + (setq overlay (make-overlay (point) last-end nil nil t)) + (overlay-put overlay 'brokenp t) + (overlay-put overlay 'face guile-broken-face) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + ;; And link it in... + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail)))))) + ;; Broken overlay... Here we go again! + (guile-backward-broken-sexp) + (while (and overlays + (> (overlay-start (car overlays)) (point))) + (let ((id (overlay-get (car overlays) 'id))) + (delete-overlay (car overlays)) + (if id + (scheme-virtual-unlink id))) + (setq overlays (cdr overlays))) + (if (and overlays + (= (overlay-start (car overlays)) (point))) + (progn + (setq overlay (car overlays)) + (move-overlay overlay (point) last-end) + (setcdr tail overlays) + (setq tail (cdr tail)) + (setq overlays (cdr overlays))) + (setq overlay (make-overlay (point) last-end nil nil t)) + (overlay-put overlay 'modification-hooks + '(guile-handle-modification)) + (setcdr tail (cons overlay overlays)) + (setq tail (cdr tail))) + (overlay-put overlay 'brokenp t) + (overlay-put overlay 'face guile-broken-face)) + (if (overlay-get (car tail) 'brokenp) + (progn + (setq first-broken (car tail)) + (if (not last-broken) + (setq last-broken (car tail))))) + (setq last-end (point)))) + (if (not tailp) + (progn + (setq scheme-buffer-overlays + (cdr guile-tail-cons)) + ;; Don't let the rear-stickiness propagate upwards... + (if scheme-buffer-last-overlay + (if (not (eq (car scheme-buffer-overlays) + scheme-buffer-last-overlay)) + (progn + (overlay-put scheme-buffer-last-overlay + 'insert-behind-hooks + nil) + (overlay-put (car scheme-buffer-overlays) + 'insert-behind-hooks + '(rear-sticky-overlay-function + guile-handle-modification)))) + (overlay-put (car scheme-buffer-overlays) + 'insert-behind-hooks + '(rear-sticky-overlay-function guile-handle-modification))) + (setq scheme-buffer-last-overlay + (car scheme-buffer-overlays)))) + (setq guile-last-broken last-broken) + (setq guile-repair-limit + (if first-broken + ;(overlay-start + ; (let ((ovls (memq first-broken scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; first-broken) + (overlay-start first-broken) + guile-big-integer))) + (if guile-show-overlays-p + (guile-show-overlays)) + ) + +(defvar guile-last-broken nil) +(defvar guile-repair-limit guile-big-integer) + +(defun guile-handle-modification (overlay after from to &optional length) + (if after + (progn + (overlay-put overlay 'brokenp t) + (setq scheme-buffer-overlays-modified-p t) + (if guile-last-broken + (if (< (overlay-start overlay) guile-repair-limit) + (setq guile-repair-limit + ;(overlay-start + ; (let ((ovls (memq overlay scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; overlay))) + (overlay-start overlay)) + (if (> (overlay-start overlay) + (overlay-start guile-last-broken)) + (setq guile-last-broken overlay))) + (setq guile-last-broken overlay) + (setq guile-repair-limit + ;(overlay-start + ; (let ((ovls (memq overlay scheme-buffer-overlays))) + ; (or (and ovls (cdr ovls) (car (cdr ovls))) + ; overlay))) + (overlay-start overlay)))))) + +(defun guile-repair-overlays () + (if (and (eq major-mode 'scheme-mode) + scheme-buffer-overlays-modified-p) + (save-excursion + ;(ding) + ;(message "Repair!") + (setq scheme-buffer-modified-p t) + (if scheme-associated-process-buffer + (setq guile-synchronizedp nil)) + (guile-reparse-buffer guile-last-broken guile-repair-limit) + (guile-modularize scheme-buffer-overlays) + (setq scheme-buffer-overlays-modified-p nil)))) + +(defun guile-modularize (r-overlays) + (let ((overlays (reverse r-overlays)) + (module nil)) + (while overlays + (if (overlay-get (car overlays) 'define-module) + (progn + (overlay-put (car overlays) 'module-overlay nil) + (setq module (car overlays))) + (overlay-put (car overlays) 'module-overlay module)) + (setq overlays (cdr overlays))))) + +(defun guile-backward-broken-sexp () + (interactive) + (beginning-of-line) + (let ((last (point))) + (while (not (or (bobp) + (and (eq (following-char) ?\() + (guile-safe-backward-sexp) + (bolp)))) + (forward-line -1) + (beginning-of-line) + (setq last (point))) + (let ((end (point))) + (goto-char (if (guile-safe-forward-sexp) + last + end))))) + +;; rear-sticky-overlay-function: +;; Put this function in the `insert-behind-hooks' of an overlay +;; in order to make the overlay rear-sticky. + +(defun rear-sticky-overlay-function (overlay after from to &optional length) + (if after + (move-overlay overlay (overlay-start overlay) to))) + +;;; Some debugging utilities +;;; + +(defvar guile-show-overlays-p nil) + +(defun guile-show-overlays () + (interactive) + (if (guile-enhancedp) + (let ((n 1) + (color nil) + (previous nil) + (overlays scheme-buffer-overlays)) + (if (null overlays) + (progn + (ding) + (message "Empty overlay list!")) + (if (not (memq 'rear-sticky-overlay-function + (overlay-get (car overlays) 'insert-behind-hooks))) + (progn + (ding) + (message "Last overlay not rear-sticky!"))) + (while overlays + (overlay-put (car overlays) + 'face + (if (setq color (not color)) + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face-1 + (if (overlay-get (car overlays) 'modifiedp) + guile-modified-face-1 + guile-unmodified-face-1)) + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face-2 + (if (overlay-get (car overlays) 'modifiedp) + guile-modified-face-2 + guile-unmodified-face-2)))) + (if previous + (progn + (if (/= (overlay-end (car overlays)) + (overlay-start previous)) + (progn (ding) + (message "Bad end boundary at overlay no. %d" n))) + (if (overlay-get (car overlays) 'insert-behind-hooks) + (progn + (ding) + (message "Inner overlay no. %d rear-sticky!" n))))) + (setq previous (car overlays)) + (setq n (1+ n)) + (setq overlays (cdr overlays))) + (if (/= (overlay-start previous) (point-min)) + (progn + (ding) + (message "First overlay doesn't start at %d" (point-min))))))) + (setq guile-show-overlays-p t)) + +(defun guile-hide-overlays () + (interactive) + (let ((color nil) + (overlays scheme-buffer-overlays)) + (while overlays + (overlay-put (car overlays) + 'face + (if (overlay-get (car overlays) 'brokenp) + guile-broken-face + nil)) + (setq overlays (cdr overlays)))) + (setq guile-show-overlays-p nil)) + +;; *fixme* Consider removing this function +(defun guile-kill-overlays (&optional ls) + (interactive) + (if (not ls) + (progn + (setq ls (apply (function append) + (mapcar (function cdr) + scheme-virtual-file-list))) + (setq scheme-virtual-file-list ()))) + (while ls + (delete-overlay (car ls)) + (setq ls (cdr ls)))) + +;; *fixme* Consider removing this function +(defun overlay-kill () + (interactive) + (delete-overlay (car (overlays-at (point))))) + +(defun for-each (func ls) + (while ls + (funcall func (car ls)) + (setq ls (cdr ls)))) + + +;;; Completion + +(defconst guile-symbol-chars "---A-ZÅÄÖa-zåäö0-9!$%&/=?@+*<>|-_:.") + +(defun guile-match-symnames (word &optional exactp) + (if (not word) + '() + (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(map symbol->string + (%%apropos-internal + ,(concat "^" + (regexp-quote word) + (and exactp "$")))))))) + +(defmacro guile-force-splittable (&rest forms) + `(let ((f (selected-frame)) + (w (selected-window))) + (let ((unsplittable (assq 'unsplittable (frame-parameters f))) + (dedicatedp (window-dedicated-p w)) + (same-window-buffer-names + (append same-window-buffer-names + (list (buffer-name (window-buffer w)))))) + (unwind-protect + (progn + (modify-frame-parameters f '((unsplittable . nil))) + (set-window-dedicated-p w nil) + ,@forms) + (modify-frame-parameters f (list unsplittable)) + (set-window-dedicated-p w dedicatedp))))) + +(defvar guile-complete-function 'comint-dynamic-complete) + +(defun guile-indent-or-complete () + (interactive) + (let ((beg (save-excursion + (beginning-of-line) + (point)))) + (if (guile-whitespace-between-p beg (point)) + (funcall 'indent-for-tab-command) + (funcall guile-complete-function)))) + +(defun guile-complete-symbol () + (interactive) + (let ((word (comint-word guile-symbol-chars))) + (if word + (progn + (guile-force-splittable + (comint-dynamic-simple-complete word (guile-match-symnames word))) + (if (string= (buffer-name) scheme-buffer) + (put-text-property comint-last-output-start + (point) 'face 'bold)))))) + +(defun guile-list-completions () + (interactive) + (let* ((word (comint-word guile-symbol-chars)) + (candidates (mapcar (function (lambda (x) (list x))) + (guile-match-symnames word))) + (completions (all-completions word candidates))) + (if (null completions) + (message "No completions of %s" word) + (guile-force-splittable + (comint-dynamic-list-completions completions)) + (if (string= (buffer-name) scheme-buffer) + (put-text-property comint-last-output-start (point) 'face 'bold))))) + +;;; Documentation + +(defun guile-documentation-symbols () + (save-excursion + (set-buffer scheme-buffer) + (guile-eval '(map symbol->string (%%apropos-internal ""))))) + +(defun guile-variable-at-point (symnames) + (condition-case () + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table scheme-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (following-char)) ?w) + (eq (char-syntax (following-char)) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (member (symbol-name obj) symnames) obj))) + (set-syntax-table stab))) + (error nil))) + +(defun guile-describe-variable (variable) + "Display the full documentation of Guile variable VARIABLE." + (interactive + (let ((symnames (guile-documentation-symbols))) + (let ((symbol (guile-variable-at-point symnames)) + (enable-recursive-minibuffers t) + val) + (setq val (completing-read (if symbol + (format "Describe Guile variable (default %s): " symbol) + "Describe Guile variable: ") + (mapcar (lambda (s) + (cons s '())) + symnames) + nil t)) + (list (if (equal val "") + symbol + (intern val)))))) + (guile-force-splittable + (with-output-to-temp-buffer "*Help*" + (prin1 variable) + (princ ": ") + (princ (save-excursion + (set-buffer scheme-buffer) + (guile-eval variable t))) + (terpri) + (terpri) + (let ((doc (save-excursion + (set-buffer scheme-buffer) + (guile-eval `(%%emacs-symdoc ',variable))))) + (if doc + (princ doc) + (princ "not documented"))) + (print-help-return-message) + (save-excursion + (set-buffer standard-output) + (help-mode) + ;; Return the text we displayed. + (buffer-string))))) + +(provide 'guile) +(run-hooks 'guile-load-hook) diff --git a/emacs/guileint/guileint.el b/emacs/guileint/guileint.el new file mode 100644 index 000000000..93c03c7a2 --- /dev/null +++ b/emacs/guileint/guileint.el @@ -0,0 +1,117 @@ +;;; NAME: guileint.el +;;; SYNOPSIS: A Guile/Emacs interface prototype +;;; VERSION: 1.5 +;;; LAST CHANGE: 2002-10-19 +;;; CREATED: 1997-07-17 +;;; AUTHOR: Mikael Djurfeldt +;;; COPYRIGHT: (C) 1997, 2002 Mikael Djurfeldt +;;; +;;; Verbatim copies of this file may be freely redistributed. +;;; +;;; Modified versions of this file may be redistributed provided that this +;;; notice remains unchanged, the file contains prominent notice of +;;; author and time of modifications, and redistribution of the file +;;; is not further restricted in any way. +;;; +;;; This file is distributed `as is', without warranties of any kind. +;;; +;;; REQUIREMENTS: +;;; +;;; USAGE: +;;; +;;; BUGS: +;;; +;;; +;;; Setup load-path + +(if (featurep 'guileint) + nil + +(require 'cl-19 "cl") + +(defconst guileint-init-file "guileint") + +(defvar guileint-emacs-dir nil) +(let ((pathlist (getenv "EMACSSITELOAD"))) + (if (and pathlist + (string-match (concat "\\(\\(/[^:/]+\\)*\\)/?" + guileint-init-file + "\\(\.elc?\\)?\\(:\\|\\'\\)") + pathlist)) + (setq guileint-emacs-dir (match-string 1 pathlist)))) + +(defvar guileint-default-load-path load-path) +(setq load-path + (append (list + guileint-emacs-dir + ) + guileint-default-load-path + '( + ))) + +(setq scheme-program-name + (let ((v (getenv "SCHEME_PROGRAM_NAME"))) + (or v + (concat "guile" + (and window-system " --emacs"))))) + +;;; Select buffers to pop up as separate windows +(if window-system + (progn + (defvar default-special-display-buffer-names + special-display-buffer-names) + (setq special-display-buffer-names + (union default-special-display-buffer-names '("*scheme*"))) + + (setq same-window-buffer-names + (delete "*scheme*" same-window-buffer-names)) + + (setq special-display-frame-alist + '((height . 24) (width . 80) (unsplittable . t))) + )) + +;;; Do things to support lisp-hacking better +(if (equal (substring emacs-version 0 2) "19") + ;; Emacs version 19 specific initializations + (progn + (copy-face 'default 'paren) + (condition-case err + (make-face-bold 'paren) + (error)) + (setq show-paren-face 'paren) + (require 'paren) + ;; The old parenthesis matcher has the advantage of displaying + ;; non-visible matching parenthesis in the minibuffer. + ;; Since paren.el adds (setq blink-paren-function nil) to the + ;; window-setup-hook it's necessary to put this setq there + ;; also. + (add-hook 'window-setup-hook (function restore-blink-paren) t) + (setq blink-matching-delay 0.5) + )) + +(defun restore-blink-paren () + (interactive) + (setq blink-matching-paren-on-screen t) + (set-face-underline-p 'paren t)) + +;;; Menus +;;; + +(require 'defmenu) + +;(setq menu-bar-final-items +; '(completion inout signals scheme help-menu)) +(setq menu-bar-final-items + '(interpret scheme help-menu)) + +;; The global menu +;; +(define-menu global-map 'interpret "Interpret" + '(("Guile" run-scheme (not (comint-check-proc "*scheme*"))) + ("Switch to *scheme*" guile-switch-to-scheme + (comint-check-proc "*scheme*")))) + +(load "inda-scheme") + +(provide 'guileint) +) diff --git a/emacs/guileint/inda-scheme.el b/emacs/guileint/inda-scheme.el new file mode 100644 index 000000000..8c2f8b502 --- /dev/null +++ b/emacs/guileint/inda-scheme.el @@ -0,0 +1,201 @@ +;;; NAME: inda-scheme.el +;;; SYNOPSIS: Customizations of the scheme modes for +;;; the INDA course at NADA/KTH +;;; VERSION: 1.0 +;;; LAST CHANGE: 950827 +;;; CREATED: 950827 +;;; AUTHOR: Mikael Djurfeldt +;;; COPYRIGHT: (C) Mikael Djurfeldt 1995 +;;; +;;; Verbatim copies of this file may be freely redistributed. +;;; +;;; Modified versions of this file may be redistributed provided that this +;;; notice remains unchanged, the file contains prominent notice of +;;; author and time of modifications, and redistribution of the file +;;; is not further restricted in any way. +;;; +;;; This file is distributed `as is', without warranties of any kind. +;;; +;;; REQUIREMENTS: +;;; +;;; USAGE: +;;; +;;; BUGS: +;;; +;;; + +(require 'guile-init) + +;;; Customizations of the scheme modes + +(defun inda-scheme-mode-initializations () + (define-key scheme-mode-map "\r" 'newline-and-indent) + ;(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go) + (define-key scheme-mode-map [S-mouse-2] 'guile-frame-eval-at-click) + (define-key scheme-mode-map [triple-mouse-1] 'inda-mark-sexp) ;*fixme* + (define-key scheme-mode-map "\C-c\C-b" 'scheme-send-buffer) + (define-key scheme-mode-map "(" 'scheme-electric-open-paren) + (define-key scheme-mode-map "[" 'scheme-electric-open-paren) + (define-key scheme-mode-map ")" 'scheme-close-paren) + (define-key scheme-mode-map "]" 'scheme-close-paren) + (define-key scheme-mode-map "\M-?" 'guile-list-completions) + (define-key scheme-mode-map "\C-cd" 'guile-describe-variable) + (define-key scheme-mode-map "\M-\t" 'guile-complete-symbol) + (put 'procedure->macro 'scheme-indent-function 0) + (put 'procedure->memoizing-macro 'scheme-indent-function 0) + (put 'bind 'scheme-indent-function 1) + (put 'letrec* 'scheme-indent-function 1) + (put 'syntax-rules 'scheme-indent-function 1) + (put 'syntax-case 'scheme-indent-function 2) + (put 'define-syntax 'scheme-indent-function 1) + (put 'with-syntax 'scheme-indent-function 1)) + +(add-hook 'scheme-mode-hook (function inda-scheme-mode-initializations)) + +(defun scheme-electric-open-paren () + (interactive) + (insert last-input-char) + (let ((old-point (point))) + (indent-for-tab-command) + (if (not (eq (char-after (1- (point))) last-input-char)) + (goto-char old-point)))) + +(defun scheme-close-paren () + (interactive) + (insert last-input-char) + (if (guile-enhancedp) + (guile-repair-overlays)) + (if blink-paren-function + (funcall blink-paren-function))) + +(defun inda-send-definition (click) + "Position point and send definition to the inferior Scheme process." + (interactive "e") + (mouse-set-point click) + (sit-for 0) + (scheme-send-definition)) + +(defun inda-mark-sexp () + (interactive) + (beginning-of-defun) + (mark-sexp)) + +(defvar inda-read-only-overlay nil) + +(defun inda-inferior-initializations () + (setq guile-kill-buffer-on-death t) + ;; The following seems already to be done in comint-mode... + ;;(add-hook 'pre-command-hook (function comint-preinput-scroll-to-bottom)) + (setq comint-scroll-to-bottom-on-input 'this) + (setq comint-scroll-to-bottom-on-output nil) + + ;; Some key bindings. + (define-key inferior-scheme-mode-map "\C-a" 'comint-bol) + (define-key inferior-scheme-mode-map [C-a] 'comint-bol) + (define-key inferior-scheme-mode-map "\C-c\C-a" 'beginning-of-line) + (define-key inferior-scheme-mode-map [C-c C-a] 'beginning-of-line) + (define-key inferior-scheme-mode-map "\r" 'guile-send-input) + (define-key inferior-scheme-mode-map "\t" 'guile-indent-or-complete) + (define-key inferior-scheme-mode-map "\M-?" 'guile-list-completions) + (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable) + (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable) + + ;; Create the read-only overlay. + (make-local-variable 'inda-read-only-overlay) + (cond ((not (overlayp inda-read-only-overlay)) + (setq inda-read-only-overlay (make-overlay 1 (point))) + (overlay-put inda-read-only-overlay 'modification-hooks + '(inda-barf-at-modifications)))) + + ;; Disable font-lock + (make-local-variable 'font-lock-fontify-region-function) + (setq font-lock-fontify-region-function 'ignore) + + ;; We don't want all comint modes to have these values + (add-hook 'comint-input-filter-functions + (function inda-make-input-memory) 'append 'local) + (add-hook 'comint-input-filter-functions + (function inda-extend-read-only-overlay) 'append 'local) + (add-hook 'comint-output-filter-functions + (function inda-extend-read-only-overlay) 'append 'local) + (add-hook 'comint-output-filter-functions + (function inda-reset-guile-last-output) 'append 'local) + ;; This is a bit kludgy... + (add-hook 'scheme-enter-input-wait-hook (function inda-boldify-previous-character)) +) + +;; No message about reason when process dies + +(setq guile-insert-reason nil) + +(add-hook 'inferior-scheme-mode-hook + (function inda-inferior-initializations) + 'append) + +(require 'defmenu) + +;; Scheme mode menu +;; +(fset 'scheme-advanced-menu + (make-menu + "Advanced" + '( + ("Sync with scheme" guile-sync-with-scheme + (and (> guile-n-enhanced-buffers 0) + (not (guile-synchronizedp)) + scheme-ready-p)) + ("Re-eval buffer" guile-reread-buffer (and (guile-attachedp) + scheme-ready-p)) + () + ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) + ("Normal edit" guile-normal-edit (and (guile-enhancedp) + (not (guile-attachedp)))) + () + ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) + ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) + ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) + ))) + +(define-menu scheme-mode-map 'scheme "Scheme" + '( + ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) + ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) + ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) + ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) + () + ("Indent buffer" indent-buffer) + ("Indent region" indent-region) + ("Indent definition" indent-defun) + () + ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) + ("Normal edit" guile-normal-edit (and (guile-enhancedp) + (not (guile-attachedp)))) + () + ("Attach buffer" guile-attach-buffer (and (comint-check-proc "*scheme*") + scheme-ready-p + (not (guile-attachedp)))) + ("Detach buffer" guile-detach-buffer (guile-attachedp)) + () + ("Re-init buffer" guile-reread-buffer (and (guile-attachedp) + scheme-ready-p)) + ("Find bad expressions" guile-check-all (> guile-n-enhanced-buffers 0)) + )) + +;(define-key scheme-mode-map [menu-bar interpret] 'undefined) + +;; Inferior scheme menu +;; +(define-menu inferior-scheme-mode-map 'scheme "Scheme" + '(("Start scheme" run-scheme (not (comint-check-proc "*scheme*"))) + ("Restart scheme" guile-restart-scheme (comint-check-proc "*scheme*")) + ("Exit scheme" guile-exit-scheme (comint-check-proc "*scheme*")) + () + ("Load file..." guile-load-file + (and (comint-check-proc "*scheme*") + scheme-ready-p)) + ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) + ("Find bad expressions" guile-check-all (comint-check-proc "*scheme*")) + () + ("Clear transcript" guile-clear-transcript (comint-check-proc "*scheme*")))) + +(define-key inferior-scheme-mode-map [menu-bar interpret] 'undefined) diff --git a/emacs/guileint/scheme.el.diff b/emacs/guileint/scheme.el.diff new file mode 100644 index 000000000..e69de29bb diff --git a/emacs/guileint/xscheme.el.diff b/emacs/guileint/xscheme.el.diff new file mode 100644 index 000000000..e69de29bb From 7737c5f2591c02c9e7ec7654bbe19054059f4220 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 21 Aug 2003 18:13:59 +0000 Subject: [PATCH 021/109] Reorg to remove guile-init.el. --- emacs/guileint/ChangeLog | 16 ++++ emacs/guileint/guile-init.el | 152 ---------------------------------- emacs/guileint/inda-scheme.el | 101 ++++++++++++++++++++++ 3 files changed, 117 insertions(+), 152 deletions(-) delete mode 100644 emacs/guileint/guile-init.el diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog index 11c6de786..d39c6f8af 100644 --- a/emacs/guileint/ChangeLog +++ b/emacs/guileint/ChangeLog @@ -1,3 +1,19 @@ +2003-08-21 Neil Jerram + + * guile-init.el: Removed (because now empty). + + * inda-scheme.el (scheme-send-buffer, indent-buffer, + indent-defun): Moved here from guile-init.el. + + * guile-init.el (inda-boldify): Removed (because unused). + + * inda-scheme.el (inda-barf-at-modifications, + inda-boldify-previous-character, inda-make-input-memory, + inda-reset-guile-last-output, inferior-scheme-mode-map mouse + bindings, inda-mouse-yank-at-click, inda-insert-input-memory, + inda-insert-input-memory-and-send, inda-extend-read-only-overlay): + Moved here from guile-init.el. + 2003-08-20 Neil Jerram Import of Mikael's guileint-1.5.2.tgz into Guile CVS ... diff --git a/emacs/guileint/guile-init.el b/emacs/guileint/guile-init.el deleted file mode 100644 index e75f4b69b..000000000 --- a/emacs/guileint/guile-init.el +++ /dev/null @@ -1,152 +0,0 @@ -;;; @(#) guile-init.el -- -;;; @(#) $Keywords: $ - -;; Copyright (C) 1995 Mikael Djurfeldt - -;; LCD Archive Entry: -;; guile-init|djurfeldt@nada.kth.se| -;; A GNU Emacs extension which | -;; $Date: 2003-08-20 19:00:44 $|$Revision: 1.1 $|~/misc/.el.Z| - -;; Author: Mikael Djurfeldt -;; Version: 1.0 - -;; 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 of the License, 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 GNU Emacs. If you did not, write to the Free Software Foundation, -;; Inc., 675 Mass Ave., Cambridge, MA 02139, USA. - -;;; Commentary: -;; -;; Requirements: -;; -;; Usage: -;; -;; Bugs: -;; -;; - -(defvar guile-init-load-hook nil - "*Hook run when file is loaded") - -(require 'guile) - -;;; Misc. interactivity -;;; -;;; -(defun inda-barf-at-modifications (&rest args) - (or inhibit-read-only - (error "Attempt to modify read-only text"))) - -(defun inda-boldify-previous-character () - ;; Must check this so that we don't point outside buffer... - (if (> (point) (point-min)) - (let ((inhibit-read-only t)) - (put-text-property (1- (point)) (point) 'face 'bold)))) - -(defun inda-make-input-memory (string) - ;; If input consists of many lines, the read-only overlay will - ;; cover the previous line, so we have to disable the protection. - (let ((inhibit-read-only t)) - ;(setq n (1+ n) - ; l (append l (list (list n 'input-filter string)))) - (if (marker-position guile-last-output-end) - (add-text-properties guile-last-output-end (1- (point)) - '(input-memory t rear-nonsticky t mouse-face highlight))))) - -(defun inda-reset-guile-last-output (string) - ;(setq n (1+ n) - ; l (append l (list (list n 'output-filter string)))) - (if (not scheme-ready-p) - (set-marker guile-last-output-end nil))) - -(define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) -(define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) - -;; Should rather be implemented with advice. -(defun inda-mouse-yank-at-click (click arg) - "Insert the last stretch of killed text at the position clicked on. -Also move point to one end of the text thus inserted (normally the end). -Prefix arguments are interpreted as with \\[yank]. -If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e\nP") - (if (get-char-property (posn-point (event-start click)) 'input-memory) - (if (memq 'shift (event-modifiers (car click))) - (inda-insert-input-memory click) - (inda-insert-input-memory-and-send click)) - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook) - (or mouse-yank-at-point (mouse-set-point click)) - (setq this-command 'yank) - (yank arg))) - -(defun inda-insert-input-memory (event) - (interactive "e") - (let* ((pos (posn-point (event-start event))) - (beg (previous-single-property-change (1+ pos) 'mouse-face)) - (end (next-single-property-change pos 'mouse-face))) - (goto-char (point-max)) - (let ((input-start (point))) - (comint-kill-input) - (insert (buffer-substring beg end)) - (add-text-properties input-start (point) - '(mouse-face nil - rear-nonsticky nil - input-memory nil))))) - -(defun inda-insert-input-memory-and-send (event) - (interactive "e") - (inda-insert-input-memory event) - (guile-send-input)) - -(defun inda-boldify (string) - (put-text-property comint-last-input-start (point) 'face 'bold)) - -(defun inda-extend-read-only-overlay (string) - (if guile-input-sent-p - (let ((inhibit-read-only t)) - (move-overlay inda-read-only-overlay (point-min) (point))))) - -;;; Misc. utilities -;;; -(defun scheme-send-buffer () - "Send the current buffer to the inferior Scheme process." - (interactive) - (let (begin end) - (save-excursion - (goto-char (point-max)) - (setq end (point)) - (goto-char (point-min)) - (setq begin (point))) - (scheme-send-region begin end))) - -(defun indent-buffer () - "Indent entire buffer." - (interactive) - (save-excursion - (end-of-buffer) - (let ((end (point))) - (beginning-of-buffer) - (indent-region (point) end nil)))) - -(defun indent-defun () - "Indent lisp definition." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (indent-region (point) end nil)))) - -(provide 'guile-init) -(run-hooks 'guile-init-load-hook) diff --git a/emacs/guileint/inda-scheme.el b/emacs/guileint/inda-scheme.el index 8c2f8b502..f40d73ec0 100644 --- a/emacs/guileint/inda-scheme.el +++ b/emacs/guileint/inda-scheme.el @@ -82,6 +82,74 @@ (defvar inda-read-only-overlay nil) +(defun inda-barf-at-modifications (&rest args) + (or inhibit-read-only + (error "Attempt to modify read-only text"))) + +(defun inda-boldify-previous-character () + ;; Must check this so that we don't point outside buffer... + (if (> (point) (point-min)) + (let ((inhibit-read-only t)) + (put-text-property (1- (point)) (point) 'face 'bold)))) + +(defun inda-make-input-memory (string) + ;; If input consists of many lines, the read-only overlay will + ;; cover the previous line, so we have to disable the protection. + (let ((inhibit-read-only t)) + ;(setq n (1+ n) + ; l (append l (list (list n 'input-filter string)))) + (if (marker-position guile-last-output-end) + (add-text-properties guile-last-output-end (1- (point)) + '(input-memory t rear-nonsticky t mouse-face highlight))))) + +(defun inda-reset-guile-last-output (string) + ;(setq n (1+ n) + ; l (append l (list (list n 'output-filter string)))) + (if (not scheme-ready-p) + (set-marker guile-last-output-end nil))) + +;; Should rather be implemented with advice. +(defun inda-mouse-yank-at-click (click arg) + "Insert the last stretch of killed text at the position clicked on. +Also move point to one end of the text thus inserted (normally the end). +Prefix arguments are interpreted as with \\[yank]. +If `mouse-yank-at-point' is non-nil, insert at point +regardless of where you click." + (interactive "e\nP") + (if (get-char-property (posn-point (event-start click)) 'input-memory) + (if (memq 'shift (event-modifiers (car click))) + (inda-insert-input-memory click) + (inda-insert-input-memory-and-send click)) + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (or mouse-yank-at-point (mouse-set-point click)) + (setq this-command 'yank) + (yank arg))) + +(defun inda-insert-input-memory (event) + (interactive "e") + (let* ((pos (posn-point (event-start event))) + (beg (previous-single-property-change (1+ pos) 'mouse-face)) + (end (next-single-property-change pos 'mouse-face))) + (goto-char (point-max)) + (let ((input-start (point))) + (comint-kill-input) + (insert (buffer-substring beg end)) + (add-text-properties input-start (point) + '(mouse-face nil + rear-nonsticky nil + input-memory nil))))) + +(defun inda-insert-input-memory-and-send (event) + (interactive "e") + (inda-insert-input-memory event) + (guile-send-input)) + +(defun inda-extend-read-only-overlay (string) + (if guile-input-sent-p + (let ((inhibit-read-only t)) + (move-overlay inda-read-only-overlay (point-min) (point))))) + (defun inda-inferior-initializations () (setq guile-kill-buffer-on-death t) ;; The following seems already to be done in comint-mode... @@ -100,6 +168,10 @@ (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable) (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable) + ;; Mouse bindings. + (define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) + (define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) + ;; Create the read-only overlay. (make-local-variable 'inda-read-only-overlay) (cond ((not (overlayp inda-read-only-overlay)) @@ -134,6 +206,35 @@ (require 'defmenu) +(defun scheme-send-buffer () + "Send the current buffer to the inferior Scheme process." + (interactive) + (let (begin end) + (save-excursion + (goto-char (point-max)) + (setq end (point)) + (goto-char (point-min)) + (setq begin (point))) + (scheme-send-region begin end))) + +(defun indent-buffer () + "Indent entire buffer." + (interactive) + (save-excursion + (end-of-buffer) + (let ((end (point))) + (beginning-of-buffer) + (indent-region (point) end nil)))) + +(defun indent-defun () + "Indent lisp definition." + (interactive) + (save-excursion + (end-of-defun) + (let ((end (point))) + (beginning-of-defun) + (indent-region (point) end nil)))) + ;; Scheme mode menu ;; (fset 'scheme-advanced-menu From fde791b502bb06013fc9b86d974f12e9d8f0b4fd Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Thu, 21 Aug 2003 18:34:43 +0000 Subject: [PATCH 022/109] Misc. file rationalization. --- emacs/guileint/ChangeLog | 10 ++ emacs/guileint/guileint.el | 26 --- emacs/guileint/inda-scheme.el | 302 --------------------------------- emacs/guileint/xscheme.el.diff | 0 4 files changed, 10 insertions(+), 328 deletions(-) delete mode 100644 emacs/guileint/xscheme.el.diff diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog index d39c6f8af..3183678f5 100644 --- a/emacs/guileint/ChangeLog +++ b/emacs/guileint/ChangeLog @@ -1,5 +1,15 @@ 2003-08-21 Neil Jerram + * xscheme.el.diff: Removed (because no diffs left). + + * inda-scheme.el (guile-init): `require' form removed. + + * guileint.el (load-path, guileint-default-load-path, + guileint-emacs-dir, guileint-init-file): Remove strange load-path + handling. + + * guileint.el: Remove guileint feature test. + * guile-init.el: Removed (because now empty). * inda-scheme.el (scheme-send-buffer, indent-buffer, diff --git a/emacs/guileint/guileint.el b/emacs/guileint/guileint.el index 93c03c7a2..e2cf108a8 100644 --- a/emacs/guileint/guileint.el +++ b/emacs/guileint/guileint.el @@ -21,34 +21,9 @@ ;;; ;;; BUGS: ;;; -;;; -;;; Setup load-path -(if (featurep 'guileint) - nil - (require 'cl-19 "cl") -(defconst guileint-init-file "guileint") - -(defvar guileint-emacs-dir nil) -(let ((pathlist (getenv "EMACSSITELOAD"))) - (if (and pathlist - (string-match (concat "\\(\\(/[^:/]+\\)*\\)/?" - guileint-init-file - "\\(\.elc?\\)?\\(:\\|\\'\\)") - pathlist)) - (setq guileint-emacs-dir (match-string 1 pathlist)))) - -(defvar guileint-default-load-path load-path) -(setq load-path - (append (list - guileint-emacs-dir - ) - guileint-default-load-path - '( - ))) - (setq scheme-program-name (let ((v (getenv "SCHEME_PROGRAM_NAME"))) (or v @@ -114,4 +89,3 @@ (load "inda-scheme") (provide 'guileint) -) diff --git a/emacs/guileint/inda-scheme.el b/emacs/guileint/inda-scheme.el index f40d73ec0..e69de29bb 100644 --- a/emacs/guileint/inda-scheme.el +++ b/emacs/guileint/inda-scheme.el @@ -1,302 +0,0 @@ -;;; NAME: inda-scheme.el -;;; SYNOPSIS: Customizations of the scheme modes for -;;; the INDA course at NADA/KTH -;;; VERSION: 1.0 -;;; LAST CHANGE: 950827 -;;; CREATED: 950827 -;;; AUTHOR: Mikael Djurfeldt -;;; COPYRIGHT: (C) Mikael Djurfeldt 1995 -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. -;;; -;;; REQUIREMENTS: -;;; -;;; USAGE: -;;; -;;; BUGS: -;;; -;;; - -(require 'guile-init) - -;;; Customizations of the scheme modes - -(defun inda-scheme-mode-initializations () - (define-key scheme-mode-map "\r" 'newline-and-indent) - ;(define-key scheme-mode-map "\C-c\C-e" 'scheme-send-definition-and-go) - (define-key scheme-mode-map [S-mouse-2] 'guile-frame-eval-at-click) - (define-key scheme-mode-map [triple-mouse-1] 'inda-mark-sexp) ;*fixme* - (define-key scheme-mode-map "\C-c\C-b" 'scheme-send-buffer) - (define-key scheme-mode-map "(" 'scheme-electric-open-paren) - (define-key scheme-mode-map "[" 'scheme-electric-open-paren) - (define-key scheme-mode-map ")" 'scheme-close-paren) - (define-key scheme-mode-map "]" 'scheme-close-paren) - (define-key scheme-mode-map "\M-?" 'guile-list-completions) - (define-key scheme-mode-map "\C-cd" 'guile-describe-variable) - (define-key scheme-mode-map "\M-\t" 'guile-complete-symbol) - (put 'procedure->macro 'scheme-indent-function 0) - (put 'procedure->memoizing-macro 'scheme-indent-function 0) - (put 'bind 'scheme-indent-function 1) - (put 'letrec* 'scheme-indent-function 1) - (put 'syntax-rules 'scheme-indent-function 1) - (put 'syntax-case 'scheme-indent-function 2) - (put 'define-syntax 'scheme-indent-function 1) - (put 'with-syntax 'scheme-indent-function 1)) - -(add-hook 'scheme-mode-hook (function inda-scheme-mode-initializations)) - -(defun scheme-electric-open-paren () - (interactive) - (insert last-input-char) - (let ((old-point (point))) - (indent-for-tab-command) - (if (not (eq (char-after (1- (point))) last-input-char)) - (goto-char old-point)))) - -(defun scheme-close-paren () - (interactive) - (insert last-input-char) - (if (guile-enhancedp) - (guile-repair-overlays)) - (if blink-paren-function - (funcall blink-paren-function))) - -(defun inda-send-definition (click) - "Position point and send definition to the inferior Scheme process." - (interactive "e") - (mouse-set-point click) - (sit-for 0) - (scheme-send-definition)) - -(defun inda-mark-sexp () - (interactive) - (beginning-of-defun) - (mark-sexp)) - -(defvar inda-read-only-overlay nil) - -(defun inda-barf-at-modifications (&rest args) - (or inhibit-read-only - (error "Attempt to modify read-only text"))) - -(defun inda-boldify-previous-character () - ;; Must check this so that we don't point outside buffer... - (if (> (point) (point-min)) - (let ((inhibit-read-only t)) - (put-text-property (1- (point)) (point) 'face 'bold)))) - -(defun inda-make-input-memory (string) - ;; If input consists of many lines, the read-only overlay will - ;; cover the previous line, so we have to disable the protection. - (let ((inhibit-read-only t)) - ;(setq n (1+ n) - ; l (append l (list (list n 'input-filter string)))) - (if (marker-position guile-last-output-end) - (add-text-properties guile-last-output-end (1- (point)) - '(input-memory t rear-nonsticky t mouse-face highlight))))) - -(defun inda-reset-guile-last-output (string) - ;(setq n (1+ n) - ; l (append l (list (list n 'output-filter string)))) - (if (not scheme-ready-p) - (set-marker guile-last-output-end nil))) - -;; Should rather be implemented with advice. -(defun inda-mouse-yank-at-click (click arg) - "Insert the last stretch of killed text at the position clicked on. -Also move point to one end of the text thus inserted (normally the end). -Prefix arguments are interpreted as with \\[yank]. -If `mouse-yank-at-point' is non-nil, insert at point -regardless of where you click." - (interactive "e\nP") - (if (get-char-property (posn-point (event-start click)) 'input-memory) - (if (memq 'shift (event-modifiers (car click))) - (inda-insert-input-memory click) - (inda-insert-input-memory-and-send click)) - ;; Give temporary modes such as isearch a chance to turn off. - (run-hooks 'mouse-leave-buffer-hook) - (or mouse-yank-at-point (mouse-set-point click)) - (setq this-command 'yank) - (yank arg))) - -(defun inda-insert-input-memory (event) - (interactive "e") - (let* ((pos (posn-point (event-start event))) - (beg (previous-single-property-change (1+ pos) 'mouse-face)) - (end (next-single-property-change pos 'mouse-face))) - (goto-char (point-max)) - (let ((input-start (point))) - (comint-kill-input) - (insert (buffer-substring beg end)) - (add-text-properties input-start (point) - '(mouse-face nil - rear-nonsticky nil - input-memory nil))))) - -(defun inda-insert-input-memory-and-send (event) - (interactive "e") - (inda-insert-input-memory event) - (guile-send-input)) - -(defun inda-extend-read-only-overlay (string) - (if guile-input-sent-p - (let ((inhibit-read-only t)) - (move-overlay inda-read-only-overlay (point-min) (point))))) - -(defun inda-inferior-initializations () - (setq guile-kill-buffer-on-death t) - ;; The following seems already to be done in comint-mode... - ;;(add-hook 'pre-command-hook (function comint-preinput-scroll-to-bottom)) - (setq comint-scroll-to-bottom-on-input 'this) - (setq comint-scroll-to-bottom-on-output nil) - - ;; Some key bindings. - (define-key inferior-scheme-mode-map "\C-a" 'comint-bol) - (define-key inferior-scheme-mode-map [C-a] 'comint-bol) - (define-key inferior-scheme-mode-map "\C-c\C-a" 'beginning-of-line) - (define-key inferior-scheme-mode-map [C-c C-a] 'beginning-of-line) - (define-key inferior-scheme-mode-map "\r" 'guile-send-input) - (define-key inferior-scheme-mode-map "\t" 'guile-indent-or-complete) - (define-key inferior-scheme-mode-map "\M-?" 'guile-list-completions) - (define-key inferior-scheme-mode-map "\C-cd" 'guile-describe-variable) - (define-key inferior-scheme-mode-map [C-c d] 'guile-describe-variable) - - ;; Mouse bindings. - (define-key inferior-scheme-mode-map [mouse-2] 'inda-mouse-yank-at-click) - (define-key inferior-scheme-mode-map [S-mouse-2] 'inda-mouse-yank-at-click) - - ;; Create the read-only overlay. - (make-local-variable 'inda-read-only-overlay) - (cond ((not (overlayp inda-read-only-overlay)) - (setq inda-read-only-overlay (make-overlay 1 (point))) - (overlay-put inda-read-only-overlay 'modification-hooks - '(inda-barf-at-modifications)))) - - ;; Disable font-lock - (make-local-variable 'font-lock-fontify-region-function) - (setq font-lock-fontify-region-function 'ignore) - - ;; We don't want all comint modes to have these values - (add-hook 'comint-input-filter-functions - (function inda-make-input-memory) 'append 'local) - (add-hook 'comint-input-filter-functions - (function inda-extend-read-only-overlay) 'append 'local) - (add-hook 'comint-output-filter-functions - (function inda-extend-read-only-overlay) 'append 'local) - (add-hook 'comint-output-filter-functions - (function inda-reset-guile-last-output) 'append 'local) - ;; This is a bit kludgy... - (add-hook 'scheme-enter-input-wait-hook (function inda-boldify-previous-character)) -) - -;; No message about reason when process dies - -(setq guile-insert-reason nil) - -(add-hook 'inferior-scheme-mode-hook - (function inda-inferior-initializations) - 'append) - -(require 'defmenu) - -(defun scheme-send-buffer () - "Send the current buffer to the inferior Scheme process." - (interactive) - (let (begin end) - (save-excursion - (goto-char (point-max)) - (setq end (point)) - (goto-char (point-min)) - (setq begin (point))) - (scheme-send-region begin end))) - -(defun indent-buffer () - "Indent entire buffer." - (interactive) - (save-excursion - (end-of-buffer) - (let ((end (point))) - (beginning-of-buffer) - (indent-region (point) end nil)))) - -(defun indent-defun () - "Indent lisp definition." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (indent-region (point) end nil)))) - -;; Scheme mode menu -;; -(fset 'scheme-advanced-menu - (make-menu - "Advanced" - '( - ("Sync with scheme" guile-sync-with-scheme - (and (> guile-n-enhanced-buffers 0) - (not (guile-synchronizedp)) - scheme-ready-p)) - ("Re-eval buffer" guile-reread-buffer (and (guile-attachedp) - scheme-ready-p)) - () - ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) - ("Normal edit" guile-normal-edit (and (guile-enhancedp) - (not (guile-attachedp)))) - () - ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) - ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) - ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) - ))) - -(define-menu scheme-mode-map 'scheme "Scheme" - '( - ("Eval definition" scheme-send-definition (comint-check-proc "*scheme*")) - ("Eval region" scheme-send-region (comint-check-proc "*scheme*")) - ("Eval buffer" scheme-send-buffer (comint-check-proc "*scheme*")) - ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) - () - ("Indent buffer" indent-buffer) - ("Indent region" indent-region) - ("Indent definition" indent-defun) - () - ("Enhanced edit" guile-enhanced-edit (not (guile-enhancedp))) - ("Normal edit" guile-normal-edit (and (guile-enhancedp) - (not (guile-attachedp)))) - () - ("Attach buffer" guile-attach-buffer (and (comint-check-proc "*scheme*") - scheme-ready-p - (not (guile-attachedp)))) - ("Detach buffer" guile-detach-buffer (guile-attachedp)) - () - ("Re-init buffer" guile-reread-buffer (and (guile-attachedp) - scheme-ready-p)) - ("Find bad expressions" guile-check-all (> guile-n-enhanced-buffers 0)) - )) - -;(define-key scheme-mode-map [menu-bar interpret] 'undefined) - -;; Inferior scheme menu -;; -(define-menu inferior-scheme-mode-map 'scheme "Scheme" - '(("Start scheme" run-scheme (not (comint-check-proc "*scheme*"))) - ("Restart scheme" guile-restart-scheme (comint-check-proc "*scheme*")) - ("Exit scheme" guile-exit-scheme (comint-check-proc "*scheme*")) - () - ("Load file..." guile-load-file - (and (comint-check-proc "*scheme*") - scheme-ready-p)) - ("Eval all changes" guile-send-changes (comint-check-proc "*scheme*")) - ("Find bad expressions" guile-check-all (comint-check-proc "*scheme*")) - () - ("Clear transcript" guile-clear-transcript (comint-check-proc "*scheme*")))) - -(define-key inferior-scheme-mode-map [menu-bar interpret] 'undefined) diff --git a/emacs/guileint/xscheme.el.diff b/emacs/guileint/xscheme.el.diff deleted file mode 100644 index e69de29bb..000000000 From 708f22c6af8c61dba2628f16d95b4e2d5b66dc1e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 01:17:48 +0000 Subject: [PATCH 023/109] (scm_difference): Correction to bignum - negative inum. --- libguile/numbers.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 5ef1310e4..7b65814bb 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3370,7 +3370,10 @@ scm_difference (SCM x, SCM y) { SCM result = scm_i_mkbig (); - mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); + if (yy >= 0) + mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); + else + mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy); scm_remember_upto_here_1 (x); if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0)) From 1fa79a38393bdf8cc98b09a90eac42a1a8a0af36 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 01:19:24 +0000 Subject: [PATCH 024/109] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a135d4ec1..4083ae3b8 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2003-08-22 Kevin Ryde + + * numbers.c (scm_difference): Correction to bignum - negative inum. + 2003-08-14 Kevin Ryde * gc.h (scm_remember_upto_here_1, scm_remember_upto_here_2) From ef016629d0e69963abacc08a5f5fef6407b17209 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 01:23:14 +0000 Subject: [PATCH 025/109] (-): Exercise bignum - inum. --- test-suite/tests/numbers.test | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 3fe309476..5cbe40ecd 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1784,7 +1784,15 @@ (pass-if "-inum - +bignum" (= #x-100000000000000000000000000000001 - (- -1 #x100000000000000000000000000000000)))) + (- -1 #x100000000000000000000000000000000))) + + (pass-if "big - inum" + (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + (- #x100000000000000000000000000000000 1))) + + (pass-if "big - -inum" + (= #x100000000000000000000000000000001 + (- #x100000000000000000000000000000000 -1)))) ;;; ;;; * From b1c602176cc798c81dd9d5d7c3997a1f8db4eab2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 01:24:59 +0000 Subject: [PATCH 026/109] *** empty log message *** --- test-suite/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index b2fa5bc00..77e18c3dc 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-08-22 Kevin Ryde + + * tests/numbers.test (-): Exercise bignum - inum. + 2003-08-17 Kevin Ryde * tests/syntax.test (while): Exercise break and continue from From f3cc3dabe6db278308b157647f2ad3aa9dc8cf10 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:28:53 +0000 Subject: [PATCH 027/109] (date-week-number): Correction, day of week starting week applied was off by one. --- srfi/srfi-19.scm | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index 198ee5d04..fd4c9c112 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -821,8 +821,13 @@ (modulo (- day-of-week-starting-week fdweek-day) 7))) +;; The "-1" here is a fix for the reference implementation, to make a new +;; week start on the given day-of-week-starting-week. date-year-day returns +;; a day starting from 1 for 1st Jan. +;; (define (date-week-number date day-of-week-starting-week) (quotient (- (date-year-day date) + 1 (priv:days-before-first-week date day-of-week-starting-week)) 7)) From ab8f1b99f13b35ebd9b751edf28353ebc2303132 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:29:29 +0000 Subject: [PATCH 028/109] Add a copyright year. --- srfi/srfi-19.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/srfi/srfi-19.scm b/srfi/srfi-19.scm index fd4c9c112..4978b96d1 100644 --- a/srfi/srfi-19.scm +++ b/srfi/srfi-19.scm @@ -1,6 +1,6 @@ ;;; srfi-19.scm --- Time/Date Library -;; Copyright (C) 2001, 2002 Free Software Foundation, Inc. +;; Copyright (C) 2001, 2002, 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 From 01dbf76f90e4850d9334aaca2f1592ff5527a8a0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:30:52 +0000 Subject: [PATCH 029/109] (date-week-number): Add tests. --- test-suite/tests/srfi-19.test | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/test-suite/tests/srfi-19.test b/test-suite/tests/srfi-19.test index 75eb25637..45a8bf1e3 100644 --- a/test-suite/tests/srfi-19.test +++ b/test-suite/tests/srfi-19.test @@ -1,7 +1,7 @@ ;;;; srfi-19.test --- test suite for SRFI-19 -*- scheme -*- ;;;; Matthias Koeppe --- June 2001 ;;;; -;;;; 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 @@ -150,7 +150,13 @@ incomplete numerical tower implementation.)" (time2 (make-time time-monotonic 385907 998360432)) (diff (time-difference time2 time1))) (test-time-arithmetic add-duration time1 diff time2) - (test-time-arithmetic subtract-duration time2 diff time1))) + (test-time-arithmetic subtract-duration time2 diff time1)) + + (with-test-prefix "date-week-number" + (pass-if (= 0 (date-week-number (make-date 0 0 0 0 1 1 1984 0) 0))) + (pass-if (= 0 (date-week-number (make-date 0 0 0 0 7 1 1984 0) 0))) + (pass-if (= 1 (date-week-number (make-date 0 0 0 0 8 1 1984 0) 0))))) + ;; Local Variables: ;; eval: (put 'with-tz 'scheme-indent-function 1) From d61261f07d54cadce8196fb99cb5d590609b8977 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:36:18 +0000 Subject: [PATCH 030/109] (list-copy): New function, derived from core list-copy but allowing improper lists, per SRFI-1 spec. --- srfi/srfi-1.c | 33 +++++++++++++++++++++++++++++++++ srfi/srfi-1.h | 1 + srfi/srfi-1.scm | 6 +++--- 3 files changed, 37 insertions(+), 3 deletions(-) diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c index 27f7dd12d..76d5678af 100644 --- a/srfi/srfi-1.c +++ b/srfi/srfi-1.c @@ -382,6 +382,39 @@ SCM_DEFINE (scm_srfi1_length_plus, "length+", 1, 0, 0, #undef FUNC_NAME +/* This routine differs from the core list-copy in allowing improper lists. + Maybe the core could allow them similarly. */ + +SCM_DEFINE (scm_srfi1_list_copy, "list-copy", 1, 0, 0, + (SCM lst), + "Return a copy of the given list @var{lst}.\n" + "\n" + "@var{lst} can be a proper or improper list. And if @var{lst}\n" + "is not a pair then it's treated as the final tail of an\n" + "improper list and simply returned.") +#define FUNC_NAME s_scm_srfi1_list_copy +{ + SCM newlst; + SCM * fill_here; + SCM from_here; + + newlst = lst; + fill_here = &newlst; + from_here = lst; + + while (SCM_CONSP (from_here)) + { + SCM c; + c = scm_cons (SCM_CAR (from_here), SCM_CDR (from_here)); + *fill_here = c; + fill_here = SCM_CDRLOC (c); + from_here = SCM_CDR (from_here); + } + return newlst; +} +#undef FUNC_NAME + + /* Typechecking for multi-argument MAP and FOR-EACH. Verify that each element of the vector ARGV, except for the first, diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h index a92f51b9b..3d23c0d4a 100644 --- a/srfi/srfi-1.h +++ b/srfi/srfi-1.h @@ -37,6 +37,7 @@ SCM_SRFI1_API SCM scm_srfi1_delete_x (SCM x, SCM lst, SCM pred); SCM_SRFI1_API SCM scm_srfi1_delete_duplicates (SCM lst, SCM pred); SCM_SRFI1_API SCM scm_srfi1_delete_duplicates_x (SCM lst, SCM pred); SCM_SRFI1_API SCM scm_srfi1_length_plus (SCM lst); +SCM_SRFI1_API SCM scm_srfi1_list_copy (SCM lst); SCM_SRFI1_API SCM scm_srfi1_map (SCM proc, SCM arg1, SCM args); SCM_SRFI1_API SCM scm_srfi1_for_each (SCM proc, SCM arg1, SCM args); SCM_SRFI1_API SCM scm_srfi1_member (SCM obj, SCM ls, SCM pred); diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm index c9555bff6..b22806ad2 100644 --- a/srfi/srfi-1.scm +++ b/srfi/srfi-1.scm @@ -43,7 +43,7 @@ ;; cons* <= in the core ;; make-list <= in the core list-tabulate - ;; list-copy <= in the core + list-copy circular-list ;; iota ; Extended. @@ -207,14 +207,14 @@ ;; set-car! <= in the core ;; set-cdr! <= in the core ) - :re-export (cons list cons* make-list list-copy pair? null? + :re-export (cons list cons* make-list pair? null? car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr list-ref last-pair length append append! reverse reverse! filter filter! memq memv assq assv set-car! set-cdr!) - :replace (iota map for-each map-in-order list-index member + :replace (iota map for-each map-in-order list-copy list-index member delete delete! assoc) ) From a54e06e5cd572b3cc754fee8b49b5321025963fb Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:37:52 +0000 Subject: [PATCH 031/109] *** empty log message *** --- srfi/ChangeLog | 8 ++++++++ test-suite/ChangeLog | 4 ++++ 2 files changed, 12 insertions(+) diff --git a/srfi/ChangeLog b/srfi/ChangeLog index aadf8041b..d41251149 100644 --- a/srfi/ChangeLog +++ b/srfi/ChangeLog @@ -1,3 +1,11 @@ +2003-08-23 Kevin Ryde + + * srfi-1.c, srfi-1.h, srfi-1.scm (list-copy): New function, derived + from core list-copy but allowing improper lists, per SRFI-1 spec. + + * srfi-19.scm (date-week-number): Correction, day of week starting + week applied was off by one. + 2003-07-29 Kevin Ryde * srfi-1.c, srfi-1.scm (concatenate, concatenate!): Use scm_append and diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 77e18c3dc..8c2a7746b 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-08-23 Kevin Ryde + + * tests/srfi-19.test (date-week-number): Add tests. + 2003-08-22 Kevin Ryde * tests/numbers.test (-): Exercise bignum - inum. From b052db6954436adaf12defa9bd7113d20d0f668f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 22:57:46 +0000 Subject: [PATCH 032/109] (list-copy): New tests. --- test-suite/tests/srfi-1.test | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 626841ebe..4b4bf392c 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -313,6 +313,26 @@ (pass-if (not (length+ (circular-list 1 2)))) (pass-if (not (length+ (circular-list 1 2 3))))) +;; +;; list-copy +;; + +(with-test-prefix "list-copy" + + ;; improper lists can be copied + (pass-if (equal? '() (list-copy '()))) + (pass-if (equal? '(1 2) (list-copy '(1 2)))) + (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) + (pass-if (equal? '(1 2 3 4) (list-copy '(1 2 3 4)))) + (pass-if (equal? '(1 2 3 4 5) (list-copy '(1 2 3 4 5)))) + + ;; improper lists can be copied + (pass-if (equal? 1 (list-copy 1))) + (pass-if (equal? '(1 . 2) (list-copy '(1 . 2)))) + (pass-if (equal? '(1 2 . 3) (list-copy '(1 2 . 3)))) + (pass-if (equal? '(1 2 3 . 4) (list-copy '(1 2 3 . 4)))) + (pass-if (equal? '(1 2 3 4 . 5) (list-copy '(1 2 3 4 . 5))))) + ;; ;; take ;; From 430110eeb2d906542d80f151f2780c8a800f2f4c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:14:11 +0000 Subject: [PATCH 033/109] *** empty log message *** --- test-suite/ChangeLog | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 8c2a7746b..8d872e54c 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,5 +1,7 @@ 2003-08-23 Kevin Ryde + * tests/srfi-1.test (list-copy): New tests. + * tests/srfi-19.test (date-week-number): Add tests. 2003-08-22 Kevin Ryde From 1363e3e71fd3161e1f37934b581cad47abc06de4 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:17:50 +0000 Subject: [PATCH 034/109] Add new "while" proper break and continue. Add srfi-1 list-copy of improper lists. --- NEWS | 15 ++++++++++++--- 1 file changed, 12 insertions(+), 3 deletions(-) diff --git a/NEWS b/NEWS index d3d433a0e..1fea1f7c1 100644 --- a/NEWS +++ b/NEWS @@ -131,6 +131,13 @@ debugging evaluator gives better error messages. * Changes to Scheme functions and syntax +** 'while' now provides 'break' and 'continue' + +break and continue were previously bound in a while loop, but not +documented, and continue didn't quite work properly. The undocumented +parameter to break which gave a return value for the while has been +dropped. + ** 'call-with-current-continuation' is now also available under the name 'call/cc'. @@ -466,10 +473,12 @@ There is no replacement for undefine. Properties set with set-source-properties! can now be read back correctly with source-properties. -** SRFI-1 delete equality argument order fixed. +** SRFI-1 fixes -In the srfi-1 module delete and delete!, the order of the arguments to -the "=" procedure now matches the SRFI-1 specification. +delete and delete! now call the "=" procedure with arguments in the +order described by the SRFI-1 specification + +list-copy now accepts improper lists, per the specification. * Changes to the C interface From c072c40c8b969b7940cd1b6843dd3143ef933363 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:23:17 +0000 Subject: [PATCH 035/109] Add a copyright year. --- libguile/simpos.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index 8c4dda542..713ff337c 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -1,4 +1,5 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,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 From f94e3e6e4b83c98a8a5c9e98aa3e41da597d86b9 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:25:02 +0000 Subject: [PATCH 036/109] (scm_system): Remove SCM_DEFER_INTS, system() should be thread safe, and could take a long time too. --- libguile/simpos.c | 2 -- 1 file changed, 2 deletions(-) diff --git a/libguile/simpos.c b/libguile/simpos.c index 713ff337c..c9c83935c 100644 --- a/libguile/simpos.c +++ b/libguile/simpos.c @@ -65,12 +65,10 @@ SCM_DEFINE (scm_system, "system", 0, 1, 0, return SCM_BOOL(rv); } SCM_VALIDATE_STRING (1, cmd); - SCM_DEFER_INTS; errno = 0; rv = system (SCM_STRING_CHARS (cmd)); if (rv == -1 || (rv == 127 && errno != 0)) SCM_SYSERROR; - SCM_ALLOW_INTS; return SCM_MAKINUM (rv); } #undef FUNC_NAME From 98dceb376e208b7072b756c60f9f70de0a2fa513 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:26:07 +0000 Subject: [PATCH 037/109] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 4083ae3b8..a821edd0b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-08-23 Kevin Ryde + + * simpos.c (scm_system): Remove SCM_DEFER_INTS, system() should be + thread safe, and could take a long time too. + 2003-08-22 Kevin Ryde * numbers.c (scm_difference): Correction to bignum - negative inum. From 36a9b2364c6fb5674121787ae25f11de8d4e135a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 22 Aug 2003 23:32:55 +0000 Subject: [PATCH 038/109] Add srfi-19 date-week-number fix. --- NEWS | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/NEWS b/NEWS index 1fea1f7c1..e9adf4ffd 100644 --- a/NEWS +++ b/NEWS @@ -480,6 +480,11 @@ order described by the SRFI-1 specification list-copy now accepts improper lists, per the specification. +** SRFI-19 fixes + +date-week-number now correctly respects the requested day of week +starting the week. + * Changes to the C interface ** Many public #defines with generic names have been made private. From bc38bb441a2f90ac65d8ad01572a77264e69509e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 25 Aug 2003 22:26:37 +0000 Subject: [PATCH 039/109] (Scientific): Add two-argument atan. --- doc/ref/scheme-data.texi | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 5046f052c..724a8c4f8 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -859,7 +859,8 @@ Return the arccosine of @var{z}. @rnindex atan @c begin (texi-doc-string "guile" "atan") @deffn {Scheme Procedure} atan z -Return the arctangent of @var{z}. +@deffnx {Scheme Procedure} atan y x +Return the arctangent of @var{z}, or of @math{@var{y}/@var{x}}. @end deffn @rnindex exp From b71d6c47ec3fcc634ab58079bb2a0083ebc8bcb3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 25 Aug 2003 23:00:05 +0000 Subject: [PATCH 040/109] *** empty log message *** --- doc/ref/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index d6b8312a4..879e1b09f 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,7 @@ +2003-08-26 Kevin Ryde + + * scheme-data.texi (Scientific): Add two-argument atan. + 2003-08-14 Kevin Ryde * scheme-control.texi (while do): Update `while' for code rewrite, in From 41e7d0f5de41b363d38a0f7546dea8a221cf785e Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 25 Aug 2003 23:02:16 +0000 Subject: [PATCH 041/109] (How guile-snarf works): Need @@ for texinfo in example. --- doc/ref/tools.texi | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/ref/tools.texi b/doc/ref/tools.texi index e3e588117..92fda23c0 100644 --- a/doc/ref/tools.texi +++ b/doc/ref/tools.texi @@ -165,7 +165,7 @@ consider using a fragment like the following in your Makefile: snarfcppopts = $(DEFS) $(INCLUDES) $(CPPFLAGS) $(CFLAGS) .SUFFIXES: .x .c.x: - guile-snarf -o $@ $< $(snarfcppopts) + guile-snarf -o $@@ $< $(snarfcppopts) @end example This tells make to run @code{guile-snarf} to produce each needed From 412d82c4f3eaeaa431ba2532ca7bf15727b919a0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 25 Aug 2003 23:18:12 +0000 Subject: [PATCH 042/109] *** empty log message *** --- doc/ref/ChangeLog | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 879e1b09f..f3a5ed5d2 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -2,6 +2,15 @@ * scheme-data.texi (Scientific): Add two-argument atan. + * tools.texi (How guile-snarf works): Need @@ for texinfo in example. + +2003-08-17 Kevin Ryde + + * scheme-compound.texi (Hash Table Reference): Collect up groups of + functions to avoid duplication. Revise notes on hashx functions and + on vector implementation. In make-hash-table, size is now optional. + Add hash-map and hash-for-each. + 2003-08-14 Kevin Ryde * scheme-control.texi (while do): Update `while' for code rewrite, in From c1ffdc6a42518a7c9c21510fd6a7120ba0b915ae Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 27 Aug 2003 23:34:53 +0000 Subject: [PATCH 043/109] (scm_remember_upto_here_1): Revise comments on the asm form. --- libguile/gc.h | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/libguile/gc.h b/libguile/gc.h index f588b3ca0..3f1556575 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -342,12 +342,17 @@ SCM_API void scm_remember_upto_here_1 (SCM obj); SCM_API void scm_remember_upto_here_2 (SCM obj1, SCM obj2); SCM_API void scm_remember_upto_here (SCM obj1, ...); -/* In GCC we can force a reference to an SCM with a little do-nothing asm, - avoiding the code size and slowdown of an actual function call. - __volatile__ ensures nothing will be moved across the reference, and that - it won't be optimized away (or rather only if proved unreachable). - Unfortunately there doesn't seem to be any way to do the varargs - scm_remember_upto_here similarly. */ +/* In GCC we can force a reference to an SCM by making it an input to an + empty asm. This avoids the code size and slowdown of an actual function + call. Unfortunately there doesn't seem to be any way to do the varargs + scm_remember_upto_here like this. + + __volatile__ ensures nothing will be moved across the asm, and it won't + be optimized away (or only if proved unreachable). Constraint "g" can be + used on all processors and allows any memory or general register (or + immediate) operand. The actual asm syntax doesn't matter, we don't want + to use it, just ensure the operand is still alive. See "Extended Asm" in + the GCC manual for more. */ #ifdef __GNUC__ #define scm_remember_upto_here_1(x) \ From 438a3ba10ddb37e8e59aec779df5268566997574 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Thu, 28 Aug 2003 00:13:06 +0000 Subject: [PATCH 044/109] *** empty log message *** --- libguile/ChangeLog | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a821edd0b..d32e8daec 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2003-08-28 Kevin Ryde + + * gc.h (scm_remember_upto_here_1): Revise comments on the asm form. + 2003-08-23 Kevin Ryde * simpos.c (scm_system): Remove SCM_DEFER_INTS, system() should be From 3adbc48c2489fa08aa18b3e315167dd54129310a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:01:17 +0000 Subject: [PATCH 045/109] (Hash Table Reference): Add hashx- case insensitive string example, add cross references to symbol-hash, string-hash, string-hash-ci, and char-set-hash. --- doc/ref/scheme-compound.texi | 39 +++++++++++++++++++++++++++--------- 1 file changed, 30 insertions(+), 9 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index 447d96249..d06ab4c69 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -2252,8 +2252,7 @@ Like the association list functions, the hash table functions come in several varieties, according to the equality test used for the keys. Plain @code{hash-} functions use @code{equal?}, @code{hashq-} functions use @code{eq?}, @code{hashv-} functions use @code{eqv?}, and -the @code{hashx-} functions use an application supplied test (for -instance to implement case insensitive strings). +the @code{hashx-} functions use an application supplied test. A single @code{make-hash-table} creates a hash table suitable for use with any set of functions, but it's imperative that just one set is @@ -2266,12 +2265,34 @@ bucket in case distinct keys hash together. Direct access to the pairs in those lists is provided by the @code{-handle-} functions. For the @code{hashx-} ``extended'' routines, an application supplies a -@var{hash} function producing an integer index (like @code{hashq} etc -below), and an @var{assoc} alist search function (like @code{assq} -etc, @xref{Retrieving Alist Entries}.). The aim in the @var{hash} -function is to have different keys spread out across the vector, so -the bucket lists don't become long, but the exact values generated are -otherwise arbitrary. +@var{hash} function producing an integer index like @code{hashq} etc +below, and an @var{assoc} alist search function like @code{assq} etc +(@pxref{Retrieving Alist Entries}). Here's an example of such +functions implementing case-insensitive hashing of string keys, + +@example +(use-modules (srfi srfi-1) + (srfi srfi-13)) +(define (my-hash str size) + (remainder (string-hash-ci str) size)) +(define (my-assoc str alist) + (find (lambda (pair) (string-ci=? str (car pair))) alist)) + +(define my-table (make-hash-table)) +(hashx-set! my-hash my-assoc my-table "foo" 123) + +(hashx-ref my-hash my-assoc my-table "FOO") +@result{} 123 +@end example + +In a @code{hashx-} @var{hash} function the aim is to spread keys +across the vector, so bucket lists don't become long, but the actual +values are arbitrary (so long as they're in the range 0 to +@math{@var{size}-1}). Helpful functions for forming a hash value, in +addition to @code{hashq} etc below, include @code{symbol-hash} +(@pxref{Symbol Keys}), @code{string-hash} and @code{string-hash-ci} +(@pxref{SRFI-13 Comparison}), and @code{char-set-hash} (@pxref{SRFI-14 +Predicates/Comparison}). @sp 1 @deffn {Scheme Procedure} make-hash-table [size] @@ -2380,7 +2401,7 @@ pair. Apply @var{proc} to the entries in the given hash @var{table}. Each call is @code{(@var{proc} @var{key} @var{value})}. @code{hash-map} returns a list of the results from these calls, @code{hash-for-each} -discards the results and returns unspecified value. +discards the results and returns an unspecified value. Calls are made over the table entries in an unspecified order, and for @code{hash-map} the order of the values in the returned list is From 05c4ffe1a7299c81ac01350e93d15d22c58e1a24 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:02:36 +0000 Subject: [PATCH 046/109] Move @contents to usual place after title page, and after first menu since that looks nice in html. --- doc/ref/guile.texi | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi index d4b8a2661..ce25a7f6c 100644 --- a/doc/ref/guile.texi +++ b/doc/ref/guile.texi @@ -129,7 +129,7 @@ notice identical to this one except for the removal of this paragraph @comment The title is printed in a large font. @title Guile Reference Manual @subtitle Edition @value{MANUAL-EDITION}, for use with Guile @value{VERSION} -@subtitle $Id: guile.texi,v 1.23 2003-07-18 00:50:23 kryde Exp $ +@subtitle $Id: guile.texi,v 1.24 2003-08-29 23:02:36 kryde Exp $ @c AUTHORS @@ -283,6 +283,8 @@ Indices @end menu +@contents + @include preface.texi @iftex @@ -386,6 +388,4 @@ available through both Scheme and C interfaces. @include indices.texi @include scheme-indices.texi -@contents - @bye From 697039a9d611338df0cea05a14b340c69cd15dbf Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:06:25 +0000 Subject: [PATCH 047/109] (Append/Reverse): Merge append and append!, shown parameters as lst1 ... lstN, describe list argument for scm_append and scm_append_x and note that it's unmodified. --- doc/ref/scheme-compound.texi | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index d06ab4c69..73b1dcaee 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -340,32 +340,34 @@ pairs. This is why you should be careful when using the side-effecting variants. @rnindex append -@deffn {Scheme Procedure} append . args -@deffnx {C Function} scm_append (args) -Return a list consisting of the elements the lists passed as -arguments. +@deffn {Scheme Procedure} append lst1 @dots{} lstN +@deffnx {Scheme Procedure} append! lst1 @dots{} lstN +@deffnx {C Function} scm_append (lstlst) +@deffnx {C Function} scm_append_x (lstlst) +Return a list comprising all the elements of lists @var{lst1} to +@var{lstN}. + @lisp (append '(x) '(y)) @result{} (x y) (append '(a) '(b c d)) @result{} (a b c d) (append '(a (b)) '((c))) @result{} (a (b) (c)) @end lisp -The resulting list is always newly allocated, except that it -shares structure with the last list argument. The last -argument may actually be any object; an improper list results -if the last argument is not a proper list. + +The last argument @var{lstN} may actually be any object; an improper +list results if the last argument is not a proper list. + @lisp (append '(a b) '(c . d)) @result{} (a b c . d) (append '() 'a) @result{} a @end lisp -@end deffn -@deffn {Scheme Procedure} append! . lists -@deffnx {C Function} scm_append_x (lists) -A destructive version of @code{append} (@pxref{Pairs and -lists,,,r5rs, The Revised^5 Report on Scheme}). The cdr field -of each list's final pair is changed to point to the head of -the next list, so no consing is performed. Return a pointer to -the mutated list. +@code{append} doesn't modify the given lists, but the return may share +structure with the final @var{lstN}. @code{append!} modifies the +given lists to form its return. + +For @code{scm_append} and @code{scm_append_x}, @var{lstlst} is a list +of the list operands @var{lst1} @dots{} @var{lstN}. That @var{lstlst} +itself is not modified or used in the return. @end deffn @rnindex reverse From 497cbe2084f49a55b8ee950ba79f705349c0b538 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:09:39 +0000 Subject: [PATCH 048/109] (Network Sockets and Communication): In socketpair, clarify the return is a pair with ports in car and cdr, note connection is full duplex, refer to socket for parameters, refer to PF_UNIX rather than AF_UNIX. --- doc/ref/posix.texi | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index c2766af51..82a45896f 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2197,11 +2197,14 @@ has been connected to another socket. @deffn {Scheme Procedure} socketpair family style proto @deffnx {C Function} scm_socketpair (family, style, proto) -Return a pair of connected (but unnamed) socket ports of the -type specified by @var{family}, @var{style} and @var{proto}. -Many systems support only socket pairs of the @code{AF_UNIX} -family. Zero is likely to be the only meaningful value for -@var{proto}. +Return a pair, the @code{car} and @code{cdr} of which are two unnamed +socket ports connected to each other. The connection is full-duplex, +so data can be transferred in either direction between the two. + +@var{family}, @var{style} and @var{proto} are as per @code{socket} +above. But many systems only support socket pairs in the +@code{PF_UNIX} family. Zero is likely to be the only meaningful value +for @var{proto}. @end deffn @deffn {Scheme Procedure} getsockopt sock level optname From 3dba2dd97bf4c76e3be0483e67960030e6acf680 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:13:48 +0000 Subject: [PATCH 049/109] (Network Sockets and Communication): In socket, use @defvar for protocol variables, cross reference for getprotobyname, note it's usually connect and accept that establishes communication. --- doc/ref/posix.texi | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 82a45896f..ce4542bb9 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -2174,25 +2174,30 @@ in host order. @deffn {Scheme Procedure} socket family style proto @deffnx {C Function} scm_socket (family, style, proto) -@vindex PF_UNIX -@vindex PF_INET -@vindex PF_INET6 -@vindex SOCK_STREAM -@vindex SOCK_DGRAM -@vindex SOCK_RAW Return a new socket port of the type specified by @var{family}, -@var{style} and @var{proto}. All three parameters are -integers. Supported values for @var{family} are -@code{PF_UNIX}, @code{PF_INET} and @code{PF_INET6}. -Typical values for @var{style} are @code{SOCK_STREAM}, -@code{SOCK_DGRAM} and @code{SOCK_RAW}. +@var{style} and @var{proto}. All three parameters are integers. The +possible values for @var{family} are as follows, where supported by +the system, + +@defvar PF_UNIX +@defvarx PF_INET +@defvarx PF_INET6 +@end defvar + +The possible values for @var{style} are as follows, again where +supported by the system, + +@defvar SOCK_STREAM +@defvarx SOCK_DGRAM +@defvarx SOCK_RAW +@end defvar @var{proto} can be obtained from a protocol name using -@code{getprotobyname}. A value of zero specifies the default -protocol, which is usually right. +@code{getprotobyname} (@pxref{Network Databases}). A value of zero +means the default protocol, which is usually right. -A single socket port cannot by used for communication until it -has been connected to another socket. +A socket cannot by used for communication until it has been connected +somewhere, usually with either @code{connect} or @code{accept} below. @end deffn @deffn {Scheme Procedure} socketpair family style proto From c6ba64cd3e983c29d55a338f60e5a7d51feff758 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:16:19 +0000 Subject: [PATCH 050/109] (Ports and File Descriptors): In pipe PIPE_BUF, use @defvar, reword a bit for clarity, cross reference glibc. --- doc/ref/posix.texi | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index ce4542bb9..2fee4ff9b 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -304,12 +304,16 @@ Pipes are commonly used for communication with a newly forked child process. The need to flush the output port can be avoided by making it unbuffered using @code{setvbuf}. -@vindex PIPE_BUF -Writes occur atomically provided the size of the data in bytes -is not greater than the value of @code{PIPE_BUF}. Note that -the output port is likely to block if too much data (typically -equal to @code{PIPE_BUF}) has been written but not yet read -from the input port. +@defvar PIPE_BUF +A write of up to @code{PIPE_BUF} many bytes to a pipe is atomic, +meaning when done it goes into the pipe instantaneously and as a +contiguous block (@pxref{Pipe Atomicity,, Atomicity of Pipe I/O, libc, +The GNU C Library Reference Manual}). +@end defvar + +Note that the output port is likely to block if too much data has been +written but not yet read from the input port. Typically the capacity +is @code{PIPE_BUF} bytes. @end deffn The next group of procedures perform a @code{dup2} From d61d8580a5f38663a36e60e1c22a68186bf55363 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:22:30 +0000 Subject: [PATCH 051/109] (Multiple Values): In values, show args as "arg1 ... argN". In scm_values, note args is a list and returned object shares structure with it. --- doc/ref/scheme-control.texi | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index 8a3884a62..a16f1dcce 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -446,13 +446,18 @@ multiple values with a procedure which accepts these values as parameters. @rnindex values -@deffn {Scheme Procedure} values . args +@deffn {Scheme Procedure} values arg1 @dots{} argN @deffnx {C Function} scm_values (args) Delivers all of its arguments to its continuation. Except for continuations created by the @code{call-with-values} procedure, all continuations take exactly one value. The effect of passing no value or more than one value to continuations that were not created by @code{call-with-values} is unspecified. + +For @code{scm_values}, @var{args} is a list of arguments and the +return is a multiple-values object which the caller can return. In +the current implementation that object shares structure with +@var{args}, so @var{args} should not be modified subsequently. @end deffn @rnindex call-with-values From bd35f1f07c5e00f2798f7e05cb8d4d4be08f7f52 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:30:00 +0000 Subject: [PATCH 052/109] (SRFI-1 Association Lists): In alist-delete and alist-delete!, note argument order for the equality calls per SRFI-1 spec. --- doc/ref/srfi-modules.texi | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 754aa31f0..795e5a188 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -774,12 +774,20 @@ spine of the list as well as the pairs are copied. @deffn {Scheme Procedure} alist-delete key alist [=] @deffnx {Scheme Procedure} alist-delete! key alist [=] -Return a list containing the pairs of @var{alist}, but without the -pairs whose @sc{cars} are equal to @var{key}. Equality is determined -by @var{=}, which defaults to @code{equal?} if not given. +Return a list containing the elements of @var{alist} but with those +elements whose keys are equal to @var{key} deleted. The returned +elements will be in the same order as they were in @var{alist}. -@code{alist-delete!} is allowed, but not required to modify the -structure of the list @var{alist} in order to produce the result. +Equality is determined by the @var{=} predicate, or @code{equal?} if +not given. The order in which elements are tested is unspecified, but +each equality call is made @code{(= key alistkey)}, ie. the given +@var{key} parameter is first and the key from @var{alist} second. +This means for instance all associations with a key greater than 5 can +be removed with @code{(alist-delete 5 alist <)}. + +@code{alist-delete} does not modify @var{alist}, but the return might +share a common tail with @var{alist}. @code{alist-delete!} may modify +the list structure of @var{alist} to construct its return. @end deffn From d3d0c186e00d80458ca5df3e770ab3c13c466d9b Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:32:21 +0000 Subject: [PATCH 053/109] (Remembering During Operations): Note scm_remember_upto_here_1 applies only to C automatic variables. --- doc/ref/data-rep.texi | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/doc/ref/data-rep.texi b/doc/ref/data-rep.texi index ba2011a52..daa22b303 100644 --- a/doc/ref/data-rep.texi +++ b/doc/ref/data-rep.texi @@ -46,7 +46,7 @@ @c essay @sp 10 @c essay @comment The title is printed in a large font. @c essay @title Data Representation in Guile -@c essay @subtitle $Id: data-rep.texi,v 1.13 2003-06-21 23:02:58 kryde Exp $ +@c essay @subtitle $Id: data-rep.texi,v 1.14 2003-08-29 23:32:21 kryde Exp $ @c essay @subtitle For use with Guile @value{VERSION} @c essay @author Jim Blandy @c essay @author Free Software Foundation @@ -1918,6 +1918,11 @@ while code is still using it. Create a reference to the given object or objects, so they're certain to be present on the stack or in a register and hence will not be freed by the garbage collector before this point. + +Note that these functions can only be applied to ordinary C local +variables (ie.@: ``automatics''). Objects held in global or static +variables or some malloced block or the like cannot be protected with +this mechanism. @end deftypefn For example, consider a procedure to convert image data to a list of From ed3bd25b1d557a70d3ec96c72cb5645eb448e6e5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:40:47 +0000 Subject: [PATCH 054/109] (Lambda): Note ". rest" list argument is always newly created. --- doc/ref/scheme-procedures.texi | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/doc/ref/scheme-procedures.texi b/doc/ref/scheme-procedures.texi index bd49aa2a4..ab71b546f 100644 --- a/doc/ref/scheme-procedures.texi +++ b/doc/ref/scheme-procedures.texi @@ -78,6 +78,12 @@ formal argument. If there are exactly @var{n} actual arguments, the empty list is stored into the location of the last formal argument. @end table +The list in @var{variable} or @var{variablen+1} is always newly +created and the procedure can modify it if desired. This is the case +even when the procedure is invoked via @code{apply}, the required part +of the list argument there will be copied (@pxref{Fly Evaluation,, +Procedures for On the Fly Evaluation}). + @var{body} is a sequence of Scheme expressions which are evaluated in order when the procedure is invoked. @end deffn From 39d27c83bae15c3d51325012903d35df798a7352 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:43:12 +0000 Subject: [PATCH 055/109] (Arithmetic): Use a table for scheme to C libm equivalences, add C99 trunc. --- doc/ref/scheme-data.texi | 23 +++++++++++++++-------- 1 file changed, 15 insertions(+), 8 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 724a8c4f8..950e8bee4 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -794,19 +794,26 @@ Round the number @var{x} towards minus infinity. Round the number @var{x} towards infinity. @end deffn -For the @code{truncate} and @code{round} procedures, the Guile library -exports equivalent C functions, but taking and returning arguments of -type @code{double} rather than the usual @code{SCM}. +C functions for some of the above rounding functions are provided by +the standard C mathematics library. Naturally these expect and return +@code{double} arguments (@pxref{Rounding Functions,,, libc, GNU C +Library Reference Manual}). + +@multitable {xx} {Scheme Procedure} {C Function} +@item @tab Scheme Procedure @tab C Function +@item @tab @code{floor} @tab @code{floor} +@item @tab @code{ceiling} @tab @code{ceil} +@item @tab @code{truncate} @tab @code{trunc} +@end multitable + +@code{trunc} is C99 standard and might not be available on older +systems. Guile provides an @code{scm_truncate} equivalent (on all +systems), plus a C level version of the Scheme @code{round} procedure. @deftypefn {C Function} double scm_truncate (double x) @deftypefnx {C Function} double scm_round (double x) @end deftypefn -For @code{floor} and @code{ceiling}, the equivalent C functions are -@code{floor} and @code{ceil} from the standard mathematics library, -which also take and return @code{double} arguments (@pxref{Rounding -Functions,,, libc, GNU C Library Reference Manual}). - @node Scientific @subsection Scientific Functions From 53872505f098b19837ec73d5ecdde987045bb4ab Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 29 Aug 2003 23:49:49 +0000 Subject: [PATCH 056/109] (Catch): Add scm_internal_catch. (Lazy Catch): Add scm_internal_lazy_catch. --- doc/ref/scheme-control.texi | 45 +++++++++++++++++++++++++++++++++++++ 1 file changed, 45 insertions(+) diff --git a/doc/ref/scheme-control.texi b/doc/ref/scheme-control.texi index a16f1dcce..d7a7f5294 100644 --- a/doc/ref/scheme-control.texi +++ b/doc/ref/scheme-control.texi @@ -662,6 +662,43 @@ the handler procedure itself throws an exception, that exception can only be caught by another active catch higher up the call stack, if there is one. +@sp 1 +@deftypefn {C Function} SCM scm_internal_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) +The above @code{scm_catch} takes Scheme procedures as body and handler +arguments. @code{scm_internal_catch} is an equivalent taking C +functions. + +@var{body} is called as @code{@var{body} (@var{body_data})} with a +catch on exceptions of the given @var{tag} type. If an exception is +caught, @var{handler} is called @code{@var{handler} +(@var{handler_data}, @var{key}, @var{args})}. @var{key} and +@var{args} are the @code{SCM} key and argument list from the +@code{throw}. + +@tpindex scm_t_catch_body +@tpindex scm_t_catch_handler +@var{body} and @var{handler} should have the following prototypes. +@code{scm_t_catch_body} and @code{scm_t_catch_handler} are pointer +typedefs for these. + +@example +SCM body (void *data); +SCM handler (void *data, SCM key, SCM args); +@end example + +The @var{body_data} and @var{handler_data} parameters are passed to +the respective calls so an application can communicate extra +information to those functions. + +If the data consists of an @code{SCM} object, care should be taken +that it isn't garbage collected while still required. If the +@code{SCM} is a local C variable, one way to protect it is to pass a +pointer to that variable as the data parameter, since the C compiler +will then know the value must be held on the stack. Another way is to +use @code{scm_remember_upto_here_1} (@pxref{Remembering During +Operations}). +@end deftypefn + @node Throw @subsection Throwing Exceptions @@ -745,6 +782,14 @@ The @var{handler} procedure is not allowed to return: it must throw to another catch, or otherwise exit non-locally. @end deffn +@deftypefn {C Function} SCM scm_internal_lazy_catch (SCM tag, scm_t_catch_body body, void *body_data, scm_t_catch_handler handler, void *handler_data) +The above @code{scm_lazy_catch} takes Scheme procedures as body and +handler arguments. @code{scm_internal_lazy_catch} is an equivalent +taking C functions. See @code{scm_internal_catch} (@pxref{Catch}) for +a description of the parameters, the behaviour however of course +follows @code{lazy-catch}. +@end deftypefn + Typically, @var{handler} should save any desired state associated with the stack at the point where the corresponding @code{throw} occurred, and then throw an exception itself --- usually the same exception as the From 1ec2dd6fd2a5d4d15c9c44ac3580805ff530b37a Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 30 Aug 2003 00:00:58 +0000 Subject: [PATCH 057/109] (lognot): Add tests. --- test-suite/tests/numbers.test | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 5cbe40ecd..8ba975964 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -2069,3 +2069,17 @@ (pass-if n (= i (logcount n)))))) +;;; +;;; lognot +;;; + +(with-test-prefix "lognot" + (pass-if (= -1 (lognot 0))) + (pass-if (= 0 (lognot -1))) + (pass-if (= -2 (lognot 1))) + (pass-if (= 1 (lognot -2))) + + (pass-if (= #x-100000000000000000000000000000000 + (lognot #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))) + (pass-if (= #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF + (lognot #x-100000000000000000000000000000000)))) From 813729f6fad84a51f84a63031d40a656d84e72b7 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 30 Aug 2003 00:02:44 +0000 Subject: [PATCH 058/109] Correction to a comment in: (list-copy): New tests. --- test-suite/tests/srfi-1.test | 2 -- 1 file changed, 2 deletions(-) diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test index 4b4bf392c..f3f898bf5 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -318,8 +318,6 @@ ;; (with-test-prefix "list-copy" - - ;; improper lists can be copied (pass-if (equal? '() (list-copy '()))) (pass-if (equal? '(1 2) (list-copy '(1 2)))) (pass-if (equal? '(1 2 3) (list-copy '(1 2 3)))) From f9811f9f2e1369cb3cc70416edced98d6887bc11 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 30 Aug 2003 00:04:42 +0000 Subject: [PATCH 059/109] (scm_lognot): Rewrite using ~ and mpz_com, for directness and to have non-integer types rejected as per other logical funcs. --- libguile/numbers.c | 17 ++++++++++++++++- 1 file changed, 16 insertions(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 7b65814bb..68d4361ce 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1247,7 +1247,22 @@ SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, "@end lisp") #define FUNC_NAME s_scm_lognot { - return scm_difference (SCM_MAKINUM (-1L), n); + if (SCM_INUMP (n)) { + /* No overflow here, just need to toggle all the bits making up the inum. + Enhancement: No need to strip the tag and add it back, could just xor + a block of 1 bits, if that worked with the various debug versions of + the SCM typedef. */ + return SCM_MAKINUM (~ SCM_INUM (n)); + + } else if (SCM_BIGP (n)) { + SCM result = scm_i_mkbig (); + mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n)); + scm_remember_upto_here_1 (n); + return result; + + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n); + } } #undef FUNC_NAME From 0f008a157a3718b33de92fd0a8f0568e012929c5 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 30 Aug 2003 00:07:49 +0000 Subject: [PATCH 060/109] *** empty log message *** --- doc/ref/ChangeLog | 45 ++++++++++++++++++++++++++++++++++++++++++++ libguile/ChangeLog | 5 +++++ test-suite/ChangeLog | 4 ++++ 3 files changed, 54 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index f3a5ed5d2..0cd1b0b58 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,48 @@ +2003-08-30 Kevin Ryde + + * data-rep.texi (Remembering During Operations): Note + scm_remember_upto_here_1 applies only to C automatic variables. + + * guile.texi: Move @contents to usual place after title page, and + after first menu since that looks nice in html. + + * posix.texi (Ports and File Descriptors): In pipe PIPE_BUF, use + @defvar, reword a bit for clarity, cross reference glibc. + + * posix.texi (Network Sockets and Communication): In socket, use + @defvar for protocol variables, cross reference for getprotobyname, + note it's usually connect and accept that establishes communication. + + * posix.texi (Network Sockets and Communication): In socketpair, + clarify the return is a pair with ports in car and cdr, note + connection is full duplex, refer to socket for parameters, refer to + PF_UNIX rather than AF_UNIX. + + * scheme-compound.texi (Append/Reverse): Merge append and append!, + shown parameters as lst1 ... lstN, describe list argument for + scm_append and scm_append_x and note that it's unmodified. + + * scheme-compound.texi (Hash Table Reference): Add hashx- case + insensitive string example, add cross references to symbol-hash, + string-hash, string-hash-ci, and char-set-hash. + + * scheme-control.texi (Multiple Values): In values, show args as "arg1 + ... argN". In scm_values, note args is a list and returned object + shares structure with it. + + * scheme-control.texi (Catch): Add scm_internal_catch. + (Lazy Catch): Add scm_internal_lazy_catch. + + * scheme-data.texi (Arithmetic): Use a table for scheme to C libm + equivalences, add C99 trunc. + + * scheme-procedures.texi (Lambda): Note ". rest" list argument is + always newly created. + + * srfi-modules.texi (SRFI-1 Association Lists): In alist-delete and + alist-delete!, note argument order for the equality calls per SRFI-1 + spec. + 2003-08-26 Kevin Ryde * scheme-data.texi (Scientific): Add two-argument atan. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d32e8daec..2a8cc3aa0 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-08-30 Kevin Ryde + + * numbers.c (scm_lognot): Rewrite using ~ and mpz_com, for directness + and to have non-integer types rejected as per other logical funcs. + 2003-08-28 Kevin Ryde * gc.h (scm_remember_upto_here_1): Revise comments on the asm form. diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 8d872e54c..7ff206a59 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,7 @@ +2003-08-30 Kevin Ryde + + * tests/numbers.test (logcount): Add tests. + 2003-08-23 Kevin Ryde * tests/srfi-1.test (list-copy): New tests. From defdc4b4ee80e099701761bb442188f31b287e28 Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sat, 30 Aug 2003 21:22:45 +0000 Subject: [PATCH 061/109] Make -s switch optional. --- THANKS | 1 + libguile/ChangeLog | 6 ++++++ libguile/script.c | 7 ++++--- 3 files changed, 11 insertions(+), 3 deletions(-) diff --git a/THANKS b/THANKS index fead9fe58..49342212b 100644 --- a/THANKS +++ b/THANKS @@ -51,6 +51,7 @@ For fixes or providing information which led to a fix: Momchil Velikov Panagiotis Vossos Neil W. Van Dyke + Aaron VanDevender Michael Talbot-Wilson Andy Wingo Keith Wright diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2a8cc3aa0..515ed998b 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-08-30 Neil Jerram + + * script.c (scm_compile_shell_switches): Make -s switch optional + if file to be loaded does not begin with a `-'. (Thanks to Aaron + VanDevender for the patch!) + 2003-08-30 Kevin Ryde * numbers.c (scm_lognot): Rewrite using ~ and mpz_com, for directness diff --git a/libguile/script.c b/libguile/script.c index debc7a43b..3e6624594 100644 --- a/libguile/script.c +++ b/libguile/script.c @@ -352,11 +352,12 @@ scm_shell_usage (int fatal, char *message) "Usage: %s OPTION ...\n" "Evaluate Scheme code, interactively or from a script.\n" "\n" - " -s SCRIPT load Scheme source code from FILE, and exit\n" + " [-s] FILE load Scheme source code from FILE, and exit\n" " -c EXPR evalute Scheme expression EXPR, and exit\n" " -- stop scanning arguments; run interactively\n" "The above switches stop argument processing, and pass all\n" "remaining arguments as the value of (command-line).\n" + "If FILE begins with `-' the -s switch is mandatory.\n" "\n" " -l FILE load Scheme source code from FILE\n" " -e FUNCTION after reading script, apply FUNCTION to\n" @@ -436,9 +437,9 @@ scm_compile_shell_switches (int argc, char **argv) for (i = 1; i < argc; i++) { - if (! strcmp (argv[i], "-s")) /* load script */ + if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */ { - if (++i >= argc) + if ((argv[i][0] == '-') && (++i >= argc)) scm_shell_usage (1, "missing argument to `-s' switch"); /* If we specified the -ds option, do_script points to the From 4559123bee8c8ca489a14b1572f1fc4c3088e03f Mon Sep 17 00:00:00 2001 From: Neil Jerram Date: Sun, 31 Aug 2003 22:59:39 +0000 Subject: [PATCH 062/109] Rewrite enhanced editing logic - sexp-track.el. --- emacs/guileint/ChangeLog | 261 ----------------------------------- emacs/guileint/guileint.el | 91 ------------ emacs/guileint/sexp-track.el | 0 3 files changed, 352 deletions(-) create mode 100644 emacs/guileint/sexp-track.el diff --git a/emacs/guileint/ChangeLog b/emacs/guileint/ChangeLog index 3183678f5..e69de29bb 100644 --- a/emacs/guileint/ChangeLog +++ b/emacs/guileint/ChangeLog @@ -1,261 +0,0 @@ -2003-08-21 Neil Jerram - - * xscheme.el.diff: Removed (because no diffs left). - - * inda-scheme.el (guile-init): `require' form removed. - - * guileint.el (load-path, guileint-default-load-path, - guileint-emacs-dir, guileint-init-file): Remove strange load-path - handling. - - * guileint.el: Remove guileint feature test. - - * guile-init.el: Removed (because now empty). - - * inda-scheme.el (scheme-send-buffer, indent-buffer, - indent-defun): Moved here from guile-init.el. - - * guile-init.el (inda-boldify): Removed (because unused). - - * inda-scheme.el (inda-barf-at-modifications, - inda-boldify-previous-character, inda-make-input-memory, - inda-reset-guile-last-output, inferior-scheme-mode-map mouse - bindings, inda-mouse-yank-at-click, inda-insert-input-memory, - inda-insert-input-memory-and-send, inda-extend-read-only-overlay): - Moved here from guile-init.el. - -2003-08-20 Neil Jerram - - Import of Mikael's guileint-1.5.2.tgz into Guile CVS ... - - * defmenu.el, fcreate.el, guile-init.el, guile.el, guileint.el, - inda-scheme.el: Imported unchanged. - - * cmuscheme.el.diff, comint.el.diff, scheme.el.diff, - xscheme.el.diff: Created by diffing Mikael's versions against the - nearest revisions I could find in Emacs CVS, so as to show the - changes made. - - * README.mdj: Renamed from Mikael's `README'. - - * README: New. - -1999-08-23 Mikael Djurfeldt - - * guile.el (guile-frame-eval): Made interactive. - (guile-error-map): Added guile-frame-eval under "e". - -1999-03-17 Mikael Djurfeldt - - * guile.el (guile-file-readable-p, guile-find-file-noselect): New - functions. Sets buffer to scheme-buffer before doing there - action. - (guile-display-scheme-sexp): Use the above functions. - -1999-03-16 Mikael Djurfeldt - - * guile.el (guile-buffer-file-name): Version of buffer-file-name - which uses file-truename; - Use guile-buffer-file-name throughout. - -1999-03-15 Mikael Djurfeldt - - * guileint.el: Add conditional in order not to load the interface - multiple times. - - * guile.el (scheme-virtual-file-list-find): New function. Finds - an finfo entry using a file name. Uses `file-truename'; - Replaced all assoc calls with scheme-vertual-file-list-find - everywhere. - (guile-real-safe-backward-sexp): New function. Can skip backwards - over special scheme hash-syntax. - (guile-send-input): Use `guile-real-safe-backward-sexp'. - -1999-03-01 Mikael Djurfeldt - - * inda-scheme.el (scheme-electric-open-paren), - guile.el (guile-indent-or-complete): Use indent-for-tab-command - instead of scheme-indent-line. - - * scheme.el: Merge changes from Emacs-20.3. - -1998-06-18 Mikael Djurfeldt - - * guile.el (guile-send-region): Bugfix: Calculate new value for - start if overlays have been skipped. - (guile-send-overlay): Send define-module overlay to define the - module before sending any other overlay belonging to that module. - (guile-reparse-buffer): Detect define-module expressions. - -1998-06-14 Mikael Djurfeldt - - * guile.el (guile-select-stackframe): Increment line number. - -1998-06-10 Mikael Djurfeldt - - * guile.el: Removed calls to the former debugging function `cb'. - -1998-05-21 Mikael Djurfeldt - - * guile.el: Added nil nil t arguments in calls to make-overlay in - order to make the overlays rear-sticky. (This is an adaption to - Emacs-20.) - -1997-10-22 Mikael Djurfeldt - - * guile.el (guile-stack-frame-map): Need to be fset in Emacs-20. - -Wed Oct 1 22:02:19 1997 Mikael Djurfeldt - - * inda-scheme.el (inda-inferior-initializations): Disable - font-lock-mode in inferior-scheme buffers. (For some strange - reason, the inda-read-only-overlay modification hook gets called - when a character is inserted after the prompt if font-lock mode - has been activated.) - -Fri Aug 29 01:34:34 1997 Mikael Djurfeldt - - * guile.el (guile-display-name): Bugfix: filler --> - guile-define-filler. - (guile-send-overlay): Bugfix: Don't print "DEFINED" if start /= - overlay-start. - Added (require 'cl). - (guile-insert-before-prompt): Use guile-last-output-end - -Wed Aug 27 17:24:28 1997 Mikael Djurfeldt - - * guile.el (guile-complete-symbol): Bugfix: Don't do anything if - word is nil. - (guile-backtrace-in-source-window): New customization option. - (guile-display-error): Don't place backtrace in source window if - guile-backtrace-in-source-window is nil. - (guile-prep-backtrace): Set syntax-table to - scheme-mode-syntax-table. - -Tue Aug 26 00:01:01 1997 Mikael Djurfeldt - - * guile.el (guile-insert-before-prompt): Move the recenter code - here. - (guile-display-name): Use guile-insert-before-prompt. - -Mon Aug 25 22:46:23 1997 Mikael Djurfeldt - - * guile.el (guile-display-name): Recenter display if prompt - started at the beginning of the buffer, so that the first text - inserted before prompt will be visible. - -Mon Aug 25 19:36:50 1997 Mikael Djurfeldt - - * guile.el: New variable: guile-frame-overlay. - (guile-inferior-initialize): Initialize guile-frame-overlay to - nil. - (guile-place-frame-overlay, guile-turn-off-frame-overlay, - guile-unselect-stackframe): New functions. - (guile-unselect-stackframe): Turn off overlay and set - guile-selected-frame to nil. - (guile-stack-frame): New overlay category. - (guile-selected-frame): defun --> defvar - (guile-exit-debug): Turn off frame overlay. - (guile-prep-backtrace): Call `guile-unselect-stackframe'. - (guile-turn-off-sexp-overlay, guile-turn-off-frame-overlay): Check - (car args) before applying `delete-overlay'. - (guile-error-map): Bind S-mouse-2 to guile-frame-eval-at-click. - - * inda-scheme.el (inda-scheme-mode-initializations): Bind - S-mouse-2 to guile-frame-eval-at-click; Bind M-TAB to - guile-complete-symbol. - - * guile.el (guile-complete-symbol): Made a command. - (guile-frame-eval-at-click, guile-frame-eval): New functions. - Enables clicking on expressions in the source buffer to show their - values. - (guile-complete-symbol, guile-list-completions): Bugfix: Use - `buffer-name' instead of `current-buffer' in order to obtain the - buffer name. - (guile-select-frame): Always set guile-selected-frame. - -Mon Aug 25 16:21:18 1997 Mikael Djurfeldt - - * guile.el (guile-eval): Must wait for scheme-ready-p so that the - filter functions don't get called. - (guile-describe-variable): Put `guile-force-splittable' around - call to `with-output-to-temp-buffer' so that documentation can be - displayed also in *scheme* window even if it is dedicated. - -Sun Aug 24 22:19:16 1997 Mikael Djurfeldt - - * *** Transferred code to guile-emacs. *** - - * inda-scheme.el (inda-inferior-initializations): Removed - assignment to scheme-pop-to-buffer. - -Thu Aug 21 01:47:31 1997 Mikael Djurfeldt - - * guile.el (guile-eval-result, guile-receive-result, guile-eval): - guile-eval-result now contains the printed representation as a - string instead of an elisp object. - (guile-eval-output): New variable. - (guile-receive-result): Set guile-eval-output to - guile-unallowed-output. - (guile-define-startcol, guile-define-filler, - guile-define-fillcol): New variables. Buffer-local. - (guile-define-header-emitted-p): New variable. - (scheme-send-region): Print result of last sent overlay or show - message "Defined." if definitions have been made. - (guile-insert-before-prompt): Don't use guile-pre-prompt-marker. - (guile-pre-prompt-marker): New name: guile-define-name-marker. - (guile-send-region): Moved printing of defined names to - guile-display-name. - (guile-send-overlay): New parameters; Zeros guile-eval-output; - Adapted to new format of %%emacs-load; Can now send sub-parts of - an overlay; Use guile-display-name. - (guile-display-name): New function. - (guile-receive-result): Reset guile-unallowed-output after having - stored its value in guile-eval-output. - -Sat Aug 16 02:53:00 1997 Mikael Djurfeldt - - * guile.el (guile-display-error): Limit height of *Scheme Error* - window to half of guile-backtrace-max-height. - -Thu Jul 24 18:41:56 1997 Mikael Djurfeldt - - * guile.el (guile-normal-edit): Don't set - scheme-buffer-modified-p. This will be done by - guile-scheme-buffer-modified next time the buffer is modified. - (guile-scheme-buffer-modified): New function. - (guile-inferior-initialize): Make first-change-hook buffer-local, - add guile-scheme-modified; Pass t for initialp to - guile-enhanced-edit if the scheme-buffer seems untouched. - - * guile.el (guile-normal-edit): Unlink overlays and buffer. - - * inda-scheme.el (inda-send-definition, inda-mark-sexp): Make it - possible to send expressions to scheme just by clicking on them. - - * guileint.el: Removed statements that doesn't have anything to do - with the Guile interface per se (transient-mark-mode, iso-syntax - etc) - -Wed Jul 23 19:11:15 1997 Mikael Djurfeldt - - * inda-scheme.el: Changed inda menu --> interpret. - -Thu Jul 17 10:43:58 1997 Mikael Djurfeldt - - * inda96.el (devel-binary): Changed to unstable. - - * guile.el (guile-display-buffers): Check for window system before - deleting windows on buffer1. - (guile-get-create-error-window): Treat non-window system - differently. - (scheme-send-region): Don't check for (scheme-ready-p) here. This - is checked in guile-send-region. - (guile-send-region): Check for (scheme-ready-p) here instead. - Go to end-of-buffer before determining proper place for "DEFINED - %s (". - -Tue Oct 15 16:56:18 1996 Mikael Djurfeldt - - * Start of revision history for misc elisp files. - diff --git a/emacs/guileint/guileint.el b/emacs/guileint/guileint.el index e2cf108a8..e69de29bb 100644 --- a/emacs/guileint/guileint.el +++ b/emacs/guileint/guileint.el @@ -1,91 +0,0 @@ -;;; NAME: guileint.el -;;; SYNOPSIS: A Guile/Emacs interface prototype -;;; VERSION: 1.5 -;;; LAST CHANGE: 2002-10-19 -;;; CREATED: 1997-07-17 -;;; AUTHOR: Mikael Djurfeldt -;;; COPYRIGHT: (C) 1997, 2002 Mikael Djurfeldt -;;; -;;; Verbatim copies of this file may be freely redistributed. -;;; -;;; Modified versions of this file may be redistributed provided that this -;;; notice remains unchanged, the file contains prominent notice of -;;; author and time of modifications, and redistribution of the file -;;; is not further restricted in any way. -;;; -;;; This file is distributed `as is', without warranties of any kind. -;;; -;;; REQUIREMENTS: -;;; -;;; USAGE: -;;; -;;; BUGS: -;;; - -(require 'cl-19 "cl") - -(setq scheme-program-name - (let ((v (getenv "SCHEME_PROGRAM_NAME"))) - (or v - (concat "guile" - (and window-system " --emacs"))))) - -;;; Select buffers to pop up as separate windows -(if window-system - (progn - (defvar default-special-display-buffer-names - special-display-buffer-names) - (setq special-display-buffer-names - (union default-special-display-buffer-names '("*scheme*"))) - - (setq same-window-buffer-names - (delete "*scheme*" same-window-buffer-names)) - - (setq special-display-frame-alist - '((height . 24) (width . 80) (unsplittable . t))) - )) - -;;; Do things to support lisp-hacking better -(if (equal (substring emacs-version 0 2) "19") - ;; Emacs version 19 specific initializations - (progn - (copy-face 'default 'paren) - (condition-case err - (make-face-bold 'paren) - (error)) - (setq show-paren-face 'paren) - (require 'paren) - ;; The old parenthesis matcher has the advantage of displaying - ;; non-visible matching parenthesis in the minibuffer. - ;; Since paren.el adds (setq blink-paren-function nil) to the - ;; window-setup-hook it's necessary to put this setq there - ;; also. - (add-hook 'window-setup-hook (function restore-blink-paren) t) - (setq blink-matching-delay 0.5) - )) - -(defun restore-blink-paren () - (interactive) - (setq blink-matching-paren-on-screen t) - (set-face-underline-p 'paren t)) - -;;; Menus -;;; - -(require 'defmenu) - -;(setq menu-bar-final-items -; '(completion inout signals scheme help-menu)) -(setq menu-bar-final-items - '(interpret scheme help-menu)) - -;; The global menu -;; -(define-menu global-map 'interpret "Interpret" - '(("Guile" run-scheme (not (comint-check-proc "*scheme*"))) - ("Switch to *scheme*" guile-switch-to-scheme - (comint-check-proc "*scheme*")))) - -(load "inda-scheme") - -(provide 'guileint) diff --git a/emacs/guileint/sexp-track.el b/emacs/guileint/sexp-track.el new file mode 100644 index 000000000..e69de29bb From 4d814788fc5efd6c1a584d9e54ad6c7e91554a17 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Sep 2003 23:00:28 +0000 Subject: [PATCH 063/109] (scm_lognot): Correction to docstring, ones-complement not 2s-complement. --- libguile/numbers.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/numbers.c b/libguile/numbers.c index 68d4361ce..a8fb84646 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1236,7 +1236,7 @@ SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0, SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0, (SCM n), - "Return the integer which is the 2s-complement of the integer\n" + "Return the integer which is the ones-complement of the integer\n" "argument.\n" "\n" "@lisp\n" From ba15f500e3d6086f514017d2021c51a65e2a3bf0 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Sep 2003 23:03:34 +0000 Subject: [PATCH 064/109] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 515ed998b..b9b1f075f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-03 Kevin Ryde + + * numbers.c (scm_lognot): Correction to docstring, ones-complement not + 2s-complement. + 2003-08-30 Neil Jerram * script.c (scm_compile_shell_switches): Make -s switch optional From 2886a7750253383fd845579c6d1d356e0e3f83d3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Sep 2003 23:55:16 +0000 Subject: [PATCH 065/109] (Keyword Primitives): Add examples to make-keyword-from-dash-symbol and keyword-dash-symbol. Add scm_c_make_keyword. --- doc/ref/scheme-data.texi | 24 ++++++++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 950e8bee4..03ad950df 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -3197,6 +3197,12 @@ retrieved using the @code{keyword-dash-symbol} procedure. @deffn {Scheme Procedure} make-keyword-from-dash-symbol symbol @deffnx {C Function} scm_make_keyword_from_dash_symbol (symbol) Make a keyword object from a @var{symbol} that starts with a dash. +For example, + +@example +(make-keyword-from-dash-symbol '-foo) +@result{} #:foo +@end example @end deffn @deffn {Scheme Procedure} keyword? obj @@ -3209,8 +3215,26 @@ Return @code{#t} if the argument @var{obj} is a keyword, else @deffnx {C Function} scm_keyword_dash_symbol (keyword) Return the dash symbol for @var{keyword}. This is the inverse of @code{make-keyword-from-dash-symbol}. +For example, + +@example +(keyword-dash-symbol #:foo) +@result{} -foo +@end example @end deffn +@deftypefn {C Function} SCM scm_c_make_keyword (char *@var{str}) +Make a keyword object from a string. For example, + +@example +scm_c_make_keyword ("foo") +@result{} #:foo +@end example +@c +@c FIXME: What can be said about the string argument? Currently it's +@c not used after creation, but should that be documented? +@end deftypefn + @node Other Types @section ``Functionality-Centric'' Data Types From 90a5894d05ea7ee10fa68e7410b280afdc541daa Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Tue, 2 Sep 2003 23:57:49 +0000 Subject: [PATCH 066/109] (Symbol Primitives): In gensym, cross reference uninterned symbols, use @w{} on " g" prefix to avoid any chance of a line break obscuring it. --- doc/ref/scheme-data.texi | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/doc/ref/scheme-data.texi b/doc/ref/scheme-data.texi index 03ad950df..7fa4ac6bd 100755 --- a/doc/ref/scheme-data.texi +++ b/doc/ref/scheme-data.texi @@ -2743,15 +2743,16 @@ code. The @code{gensym} primitive meets this need: @deffnx {C Function} scm_gensym (prefix) Create a new symbol with a name constructed from a prefix and a counter value. The string @var{prefix} can be specified as an optional -argument. Default prefix is @samp{ g}. The counter is increased by 1 +argument. Default prefix is @samp{@w{ g}}. The counter is increased by 1 at each call. There is no provision for resetting the counter. @end deffn The symbols generated by @code{gensym} are @emph{likely} to be unique, since their names begin with a space and it is only otherwise possible to generate such symbols if a programmer goes out of their way to do -so. The 1.8 release of Guile will include a way of creating -symbols that are @emph{guaranteed} to be unique. +so. Uniqueness can be guaranteed by instead using uninterned symbols +(@pxref{Symbol Uninterned}), though they can't be usefully written out +and read back in. @node Symbol Props From 03b79aa32a8d144d1361adce0ff57da2a55ce20f Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 3 Sep 2003 00:01:17 +0000 Subject: [PATCH 067/109] (scm_strptime): Add comment about glibc strptime %s and current timezone requiring SCM_DEFER_INTS. --- libguile/stime.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/stime.c b/libguile/stime.c index 08276f9f4..1d9265e96 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -647,6 +647,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, tm_init (tm_yday); #undef tm_init + /* GNU glibc strptime() "%s" is affected by the current timezone, since it + reads a UTC time_t value and converts with localtime_r() to set the tm + fields, hence the use of SCM_DEFER_INTS. */ t.tm_isdst = -1; SCM_DEFER_INTS; if ((rest = strptime (str, fmt, &t)) == NULL) From 53bb87824dbd6f9dfd38ff7e2cd6e20cce1d9ed2 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Wed, 3 Sep 2003 00:03:20 +0000 Subject: [PATCH 068/109] *** empty log message *** --- doc/ref/ChangeLog | 10 ++++++++++ libguile/ChangeLog | 3 +++ 2 files changed, 13 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 0cd1b0b58..795e841ed 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,13 @@ +2003-09-03 Kevin Ryde + + * scheme-data.texi (Keyword Primitives): Add examples to + make-keyword-from-dash-symbol and keyword-dash-symbol. Add + scm_c_make_keyword. + + * scheme-data.texi (Symbol Primitives): In gensym, cross reference + uninterned symbols, use @w{} on " g" prefix to avoid any chance of a + line break obscuring it. + 2003-08-30 Kevin Ryde * data-rep.texi (Remembering During Operations): Note diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b9b1f075f..d7c415d0e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -3,6 +3,9 @@ * numbers.c (scm_lognot): Correction to docstring, ones-complement not 2s-complement. + * stime.c (scm_strptime): Add comment about glibc strptime %s and + current timezone requiring SCM_DEFER_INTS. + 2003-08-30 Neil Jerram * script.c (scm_compile_shell_switches): Make -s switch optional From baa84a205c6c965c9e22be372e1cd01c68b4997f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 4 Sep 2003 19:21:21 +0000 Subject: [PATCH 069/109] * eq.c (scm_equal_p): Use SCM_TYP7 to check if an object is of type string, not SCM_TYP7S. --- libguile/ChangeLog | 5 +++++ libguile/eq.c | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index d7c415d0e..c0df118ad 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-04 Dirk Herrmann + + * eq.c (scm_equal_p): Use SCM_TYP7 to check if an object is of + type string, not SCM_TYP7S. + 2003-09-03 Kevin Ryde * numbers.c (scm_lognot): Correction to docstring, ones-complement not diff --git a/libguile/eq.c b/libguile/eq.c index 67abdc96e..7068eb31e 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -143,7 +143,7 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, y = SCM_CDR(y); goto tailrecurse; } - if (SCM_TYP7S (x) == scm_tc7_string && SCM_TYP7S (y) == scm_tc7_string) + if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string) return scm_string_equal_p (x, y); /* This ensures that types and scm_length are the same. */ if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) From 5d7d39ff5d54f9c2191d19bff64bb4ab8d458228 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 4 Sep 2003 20:04:30 +0000 Subject: [PATCH 070/109] * numbers.h (SCM_MAKINUM): Define in terms of scm_tc2_int. (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Define in terms of the respective SLOPPY macro. --- libguile/ChangeLog | 7 +++++++ libguile/numbers.h | 9 +++++---- 2 files changed, 12 insertions(+), 4 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index c0df118ad..082272c4d 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,10 @@ +2003-09-04 Dirk Herrmann + + * numbers.h (SCM_MAKINUM): Define in terms of scm_tc2_int. + + (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Define in terms of the + respective SLOPPY macro. + 2003-09-04 Dirk Herrmann * eq.c (scm_equal_p): Use SCM_TYP7 to check if an object is of diff --git a/libguile/numbers.h b/libguile/numbers.h index 8540d3585..c46bfe816 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -68,7 +68,8 @@ #define SCM_INUMP(x) (2 & SCM_UNPACK (x)) #define SCM_NINUMP(x) (!SCM_INUMP (x)) -#define SCM_MAKINUM(x) (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + 2)) +#define SCM_MAKINUM(x) \ + (SCM_PACK ((((scm_t_signed_bits) (x)) << 2) + scm_tc2_int)) #define SCM_INUM(x) (SCM_SRS ((scm_t_signed_bits) SCM_UNPACK (x), 2)) @@ -123,9 +124,9 @@ #define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) #define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real) #define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex) -#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_TYP16S (x) == scm_tc16_real) -#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real) -#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex) +#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_SLOPPY_INEXACTP(x)) +#define SCM_REALP(x) (!SCM_IMP (x) && SCM_SLOPPY_REALP(x)) +#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_SLOPPY_COMPLEXP(x)) #define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real) #define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x)) From 3ea39242b84a4b29fa85ed1d876468287fae3007 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 4 Sep 2003 20:14:02 +0000 Subject: [PATCH 071/109] * unit.c (scm_cvref): Eliminate unnecessary uses of SCM_NIMP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. --- libguile/ChangeLog | 5 +++++ libguile/unif.c | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 082272c4d..672d25918 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-04 Dirk Herrmann + + * unit.c (scm_cvref): Eliminate unnecessary uses of SCM_NIMP, + SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. + 2003-09-04 Dirk Herrmann * numbers.h (SCM_MAKINUM): Define in terms of scm_tc2_int. diff --git a/libguile/unif.c b/libguile/unif.c index 8b77b4a1e..7fc950f20 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1184,21 +1184,21 @@ scm_cvref (SCM v, unsigned long pos, SCM last) return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: - if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last)) + if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) { SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos]; return last; } return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]); case scm_tc7_dvect: - if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last)) + if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0)) { SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos]; return last; } return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]); case scm_tc7_cvect: - if (SCM_NIMP (last) && SCM_SLOPPY_COMPLEXP (last)) + if (SCM_COMPLEXP (last)) { SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos]; SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]; From 7e3b25bf51eb3c2dda8c981df2713ff0e9c9e438 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 4 Sep 2003 20:47:41 +0000 Subject: [PATCH 072/109] * tags.h: Added description of Guile's type system. Removed some old and misleading comments. --- libguile/ChangeLog | 5 + libguile/tags.h | 448 ++++++++++++++++++++++++++++----------------- 2 files changed, 285 insertions(+), 168 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 672d25918..1bacc8496 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-04 Dirk Herrmann + + * tags.h: Added description of Guile's type system. Removed some + old and misleading comments. + 2003-09-04 Dirk Herrmann * unit.c (scm_cvref): Eliminate unnecessary uses of SCM_NIMP, diff --git a/libguile/tags.h b/libguile/tags.h index d43d95b41..8cc293f67 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -37,7 +37,35 @@ # endif #endif + + /* In the beginning was the Word: + * + * For the representation of scheme objects and their handling, Guile provides + * two types: scm_t_bits and SCM. + * + * - scm_t_bits values can hold bit patterns of non-objects and objects: + * + * Non-objects -- in this case the value may not be changed into a SCM value + * in any way. + * + * Objects -- in this case the value may be changed into a SCM value using + * the SCM_PACK macro. + * + * - SCM values can hold proper scheme objects only. They can be changed into + * a scm_t_bits value using the SCM_UNPACK macro. + * + * When working in the domain of scm_t_bits values, programmers must keep + * track of any scm_t_bits value they create that is not a proper scheme + * object. This makes sure that in the domain of SCM values developers can + * rely on the fact that they are dealing with proper scheme objects only. + * Thus, the distinction between scm_t_bits and SCM values helps to identify + * those parts of the code where special care has to be taken not to create + * bad SCM values. + */ + +/* For dealing with the bit level representation of scheme objects we define + * scm_t_bits: */ /* On Solaris 7 and 8, /usr/include/sys/int_limits.h defines INTPTR_MAX and UINTPTR_MAX to empty, INTPTR_MIN is not defined. @@ -65,8 +93,8 @@ typedef unsigned long scm_t_bits; #endif -/* But as external interface, we use SCM, which may, according to the desired - * level of type checking, be defined in several ways: +/* But as external interface, we define SCM, which may, according to the + * desired level of type checking, be defined in several ways: */ #if (SCM_DEBUG_TYPING_STRICTNESS == 2) typedef union { struct { scm_t_bits n; } n; } SCM; @@ -98,186 +126,282 @@ typedef unsigned long scm_t_bits; -/* SCM variables can contain: +/* Representation of scheme objects: * - * Non-objects -- meaning that the tag-related macros don't apply to them - * in the usual way. + * Guile's type system is designed to work on systems where scm_t_bits and SCM + * variables consist of at least 32 bits. The objects that a SCM variable can + * represent belong to one of the following two major categories: * - * Immediates -- meaning that the variable contains an entire Scheme object. + * - Immediates -- meaning that the SCM variable contains an entire Scheme + * object. That means, all the object's data (including the type tagging + * information that is required to identify the object's type) must fit into + * 32 bits. * - * Non-immediates -- meaning that the variable holds a (possibly - * tagged) pointer into the cons pair heap. + * - Non-immediates -- meaning that the SCM variable holds a pointer into the + * heap of cells (see below). On systems where a pointer needs more than 32 + * bits this means that scm_t_bits and SCM variables need to be large enough + * to hold such pointers. In contrast to immediates, the object's data of + * a non-immediate can consume arbitrary amounts of memory: The heap cell + * being pointed to consists of at least two scm_t_bits variables and thus + * can be used to hold pointers to malloc'ed memory of any size. * - * Non-objects are distinguished from other values by careful coding - * only (i.e., programmers must keep track of any SCM variables they - * create that don't contain ordinary scheme values). + * The 'heap' is the memory area that is under control of Guile's garbage + * collector. It holds 'single-cells' or 'double-cells', which consist of + * either two or four scm_t_bits variables, respectively. It is guaranteed + * that the address of a cell on the heap is 8-byte aligned. That is, since + * non-immediates hold a cell address, the three least significant bits of a + * non-immediate can be used to store additional information. The bits are + * used to store information about the object's type and thus are called + * tc3-bits, where tc stands for type-code. * - * All immediates and pointers to cells of non-immediates have a 0 in - * bit 0. All non-immediates that are not pairs have a 1 in bit 0 of - * the first word of their cell. This is how pairs are distinguished - * from other non-immediates; a pair can have a immediate in its car - * (thus a 0 in bit 0), or a pointer to the cell of a non-immediate - * (again, this pointer has a 0 in bit 0). + * For a given SCM value, the distinction whether it holds an immediate or + * non-immediate object is based on the tc3-bits (see above) of its scm_t_bits + * equivalent: If the tc3-bits equal #b000, then the SCM value holds a + * non-immediate, and the scm_t_bits variable's value is just the pointer to + * the heap cell. * - * Immediates and non-immediates are distinguished by bits 1 and 2. - * Immediate values must have a 1 in at least one of those bits. - * Consequently, a pointer to a cell of a non-immediate must have - * zeros in bits 1 and 2. Together with the requirement from above - * that bit 0 must also be zero, this means that pointers to cells of - * non-immediates must have their three low bits all zero. This in - * turn means that cells must be aligned on a 8 byte boundary, which - * is just right for two 32bit numbers (surprise, surprise). Does - * this (or any other detail of tagging) seem arbitrary? Try changing - * it! (Not always impossible but it is fair to say that many details - * of tags are mutually dependent). */ - -#define SCM_IMP(x) (6 & SCM_UNPACK (x)) -#define SCM_NIMP(x) (!SCM_IMP (x)) - -/* Here is a summary of tagging in SCM values as they might occur in - * SCM variables or in the heap. - * - * low bits meaning + * Summarized, the data of a scheme object that is represented by a SCM + * variable consists of a) the SCM variable itself, b) in case of + * non-immediates the data of the single-cell or double-cell the SCM object + * points to, c) in case of non-immediates potentially additional data outside + * of the heap (like for example malloc'ed data), and d) in case of + * non-immediates potentially additional data inside of the heap, since data + * stored in b) and c) may hold references to other cells. * * - * 0 Most objects except... - * 1 ... structs (this tag is valid only in the header - * of a struct's data, as with all odd tags). + * Immediates * - * 00 heap addresses and many immediates (not integers) - * 01 structs, some tc7_ codes - * 10 immediate integers - * 11 various tc7_ codes including, tc16_ codes. + * Operations on immediate objects can typically be processed faster than on + * non-immediates. The reason is that the object's data can be extracted + * directly from the SCM variable (or rather a corresponding scm_t_bits + * variable), instead of having to perform additional memory accesses to + * obtain the object's data from the heap. In order to get the best possible + * performance frequently used data types should be realized as immediates. + * This is, as has been mentioned above, only possible if the objects can be + * represented with 32 bits (including type tagging). + * + * In Guile, the following data types and special objects are realized as + * immediates: booleans, characters, small integers (see below), the empty + * list, the end of file object, the 'unspecified' object (which is delivered + * as a return value by functions for which the return value is unspecified), + * a 'nil' object used in the elisp-compatibility mode and certain other + * 'special' objects which are only used internally in Guile. + * + * Integers in Guile can be arbitrarily large. On the other hand, integers + * are one of the most frequently used data types. Especially integers with + * less than 32 bits are commonly used. Thus, internally and transparently + * for application code guile distinguishes between small and large integers. + * Whether an integer is a large or a small integer depends on the number of + * bits needed to represent its value. Small integers are those which can be + * represented as immediates. Since they don't require more than a fixed + * number of bits for their representation, they are also known as 'fixnums'. + * + * The tc3-combinations #b010 and #b110 are used to represent small integers, + * which allows to use the most significant bit of the tc3-bits to be part of + * the integer value being represented. This means that all integers with up + * to 30 bits (including one bit for the sign) can be represented as + * immediates. On systems where SCM and scm_t_bits variables hold more than + * 32 bits, the amount of bits usable for small integers will even be larger. + * The tc3-code #b100 is shared among booleans, characters and the other + * special objects listed above. * * - * 000 heap address - * 001 structs - * 010 integer - * 011 closure - * 100 immediates - * 101 tc7_ - * 110 integer - * 111 tc7_ + * Non-Immediates + * + * All object types not mentioned above in the list of immedate objects are + * represented as non-immediates. Whether a non-immediate scheme object is + * represented by a single-cell or a double-cell depends on the object's type, + * namely on the set of attributes that have to be stored with objects of that + * type. Every non-immediate type is allowed to define its own layout and + * interpretation of the data stored in its cell (with some restrictions, see + * below). + * + * One of the design goals of guile's type system is to make it possible to + * store a scheme pair with as little memory usage as possible. The minimum + * amount of memory that is required to store two scheme objects (car and cdr + * of a pair) is the amount of memory required by two scm_t_bits or SCM + * variables. Therefore pairs in guile are stored in single-cells. + * + * Another design goal for the type system is to store procedure objects + * created by lambda expresssions (closures) and class instances (goops + * objects) with as little memory usage as possible. Closures are represented + * by a reference to the function code and a reference to the closure's + * environment. Class instances are represented by a reference to the + * instance's class definition and a reference to the instance's data. Thus, + * closures as well as class instances also can be stored in single-cells. + * + * Certain other non-immediate types also store their data in single-cells. + * By design decision, the heap is split into areas for single-cells and + * double-cells, but not into areas for single-cells-holding-pairs and areas + * for single-cells-holding-non-pairs. Any single-cell on the heap therefore + * can hold pairs (consisting of two scm_t_bits variables representing two + * scheme objects - the car and cdr of the pair) and non-pairs (consisting of + * two scm_t_bits variables that hold bit patterns as defined by the layout of + * the corresponding object's type). * * - * 100 --- IMMEDIATES + * Garbage collection * - * Looking at the seven final bits of an immediate: + * During garbage collection, unreachable cells on the heap will be freed. + * That is, the garbage collector will detect cells which have no SCM variable + * pointing towards them. In order to properly release all memory belonging + * to the object to which a cell belongs, the gc needs to be able to interpret + * the cell contents in the correct way. That means that the gc needs to be + * able to determine the object type associated with a cell only from the cell + * itself. * - * 0000-100 short instruction - * 0001-100 short instruction - * 0010-100 short instruction - * 0011-100 short instruction - * 0100-100 short instruction - * 0101-100 short instruction - * 0110-100 short instruction - * 0111-100 short instruction - * 1000-100 short instruction - * 1001-100 short instruction - * 1010-100 short instruction - * 1011-100 short instruction - * 1100-100 short instruction - * 1101-100 short instruction - * 1110-100 immediate characters, various immediates and long instructions - * 1111-100 ilocs + * Consequently, if the gc detects an unreachable single-cell, those two + * scm_t_bits variables must provide enough information to determine whether + * they belong to a pair (i. e. both scm_t_bits variables represent valid + * scheme objects), to a closure, a class instance or if they belong to any + * other non-immediate. Guile's type system is designed to make it possible + * to determine a the type to which a cell belongs in the majority of cases + * from the cell's first scm_t_bits variable. (Given a SCM variable X holding + * a non-immediate object, the macro SCM_CELL_TYPE(X) will deliver the + * corresponding cell's first scm_t_bits variable.) * - * Some of the 1110100 immediates are long instructions (they dispatch in - * three steps compared to one step for a short instruction). The three steps - * are, (1) dispatch on 7 bits to the long instruction handler, (2) check, if - * the immediate indicates a long instruction (rather than a character or - * other immediate) (3) dispatch on the additional bits. - * - * One way to think of it is that there are 128 short instructions, - * with the 13 immediates above being some of the most interesting. - * - * Also noteworthy are the groups of 16 7-bit instructions implied by - * some of the 3-bit tags. For example, closure references consist of - * an 8-byte aligned address tagged with 011. There are 16 identical - * 7-bit instructions, all ending 011, which are invoked by evaluating - * closures. - * - * In other words, if you hand the evaluator a closure, the evaluator - * treats the closure as a graph of virtual machine instructions. A - * closure is a pair with a pointer to the body of the procedure in - * the CDR and a pointer to the environment of the closure in the CAR. - * The environment pointer is tagged 011 which implies that the least - * significant 7 bits of the environment pointer also happen to be a - * virtual machine instruction we could call "SELF" (for - * self-evaluating object). - * - * A less trivial example are the 16 instructions ending 000. If - * those bits tag the CAR of a pair, then evidently the pair is an - * ordinary cons pair and should be evaluated as a procedure - * application. The sixteen, 7-bit 000 instructions are all - * "NORMAL-APPLY" (Things get trickier. For example, if the CAR of a - * procedure application is a symbol, the NORMAL-APPLY instruction - * will, as a side effect, overwrite that CAR with a new instruction - * that contains a cached address for the variable named by the - * symbol.) - * - * Here is a summary of tags in the CAR of a non-immediate: - * - * cons ..........SCM car..............0 ...........SCM cdr.............0 - * struct ..........void * type........001 ...........void * data.........0 - * closure ..........SCM code...........011 ...........SCM env.............0 - * tc7 ......24.bits of data...0xxxx1S1 ..........void *data............ + * If the cell holds a scheme pair, then we already know that the first + * scm_t_bits variable of the cell will hold a scheme object with one of the + * following tc3-codes: #b000 (non-immediate), #b010 (small integer), #b100 + * (small integer), #b110 (non-integer immediate). All these tc3-codes have + * in common, that their least significant bit is #b0. This fact is used by + * the garbage collector to identify cells that hold pairs. The remaining + * tc3-codes are assigned as follows: #b001 (class instance or, more + * precisely, a struct, of which a class instance is a special case), #b011 + * (closure), #b101/#b111 (all remaining non-immediate types). * * + * Summary of type codes of scheme objects (SCM variables) * - * 101 & 111 --- tc7_ types + * Here is a summary of tagging bits as they might occur in a scheme object. + * The notation is as follows: tc stands for type code as before, tc with n + * being a number indicates a type code formed by the n least significant bits + * of the SCM variables corresponding scm_t_bits value. * - * tc7_tags are 7 bit tags ending in 1x1. These tags - * occur only in the CAR of heap cells, and have the - * handy property that all bits of the CAR above the - * bottom eight can be used to store some data, thus - * saving a word in the body itself. Thus, we use them - * for strings and vectors (among other things). + * Note that (as has been explained above) tc1==1 can only occur in the first + * scm_t_bits variable of a cell belonging to a non-immediate object that is + * not a pair. For an explanation of the tc tags with tc1==1, see the next + * section with the summary of the type codes on the heap. * - * TYP7(X) returns bits 0...6 of CELL_TYPE (X) + * tc1: + * 0: For scheme objects, tc1==0 must be fulfilled. + * (1: This can never be the case for a scheme object.) * - * Sometimes we choose the bottom seven bits carefully, - * so that the 2-valued bit (called S bit) can be masked - * off to reveal a common type. + * tc2: + * 00: Either a non-immediate or some non-integer immediate + * (01: This can never be the case for a scheme object.) + * 10: Small integer + * (11: This can never be the case for a scheme object.) * - * TYP7S(X) returns TYP7, but masking out the option bit S. + * tc3: + * 000: a non-immediate object (pair, closure, class instance etc.) + * (001: This can never be the case for a scheme object.) + * 010: an even small integer (least significant bit is 0). + * (011: This can never be the case for a scheme object.) + * 100: Non-integer immediate + * (101: This can never be the case for a scheme object.) + * 110: an odd small integer (least significant bit is 1). + * (111: This can never be the case for a scheme object.) * - * Some TC7 types are subdivided into 256 subtypes giving - * rise to the macros: + * The remaining bits of the non-immediate objects form the pointer to the + * heap cell. The remaining bits of the small integers form the integer's + * value and sign. Thus, the only scheme objects for which a further + * subdivision is of interest are the ones with tc3==100. * - * TYP16 - * TYP16S + * tc7, tc8, tc9 (for objects with tc3==100): + * xx-0000-100: \ evaluator byte codes ('short instructions'). The byte + * ... } code interpreter can dispatch on them in one step based + * xx-1101-100: / on their tc7 value. + * 00-1110-100: evaluator byte codes ('long instructions'). The byte code + * interpreter needs to dispatch on them in three steps: + * The first dispatch is based on the tc7-code. The second + * dispatch checks for tc9==00-1110-100. The third dispatch + * is based on the actual byte code that is extracted from the + * upper bits. + * x1-1110-100: characters with x as their least significant bit + * 10-1110-100: various constants ('flags') + * xx-1111-100: evaluator byte codes ('ilocs') * - * TYP16S functions similarly wrt to TYP16 as TYP7S to TYP7, - * but a different option bit is used (bit 2 for TYP7S, - * bit 8 for TYP16S). + * + * Summary of type codes on the heap + * + * Here is a summary of tagging in scm_t_bits values as they might occur in + * the first scm_t_bits variable of a heap cell. + * + * tc1: + * 0: the cell belongs to a pair. + * 1: the cell belongs to a non-pair. + * + * tc2: + * 00: the cell belongs to a pair with no short integer in its car. + * 01: the cell belongs to a non-pair (struct or some other non-immediate). + * 10: the cell belongs to a pair with a short integer in its car. + * 11: the cell belongs to a non-pair (closure or some other non-immediate). + * + * tc3: + * 000: the cell belongs to a pair with a non-immediate in its car. + * 001: the cell belongs to a struct + * 010: the cell belongs to a pair with an even short integer in its car. + * 011: the cell belongs to a closure + * 100: the cell belongs to a pair with a non-integer immediate in its car. + * 101: the cell belongs to some other non-immediate. + * 110: the cell belongs to a pair with an odd short integer in its car. + * 111: the cell belongs to some other non-immediate. + * + * tc7 (for tc3==1x1): + * See below for the list of types. Note the special case of scm_tc7_vector + * and scm_tc7_wvect: vectors and weak vectors are treated the same in many + * cases. Thus, their tc7-codes are chosen to only differ in one bit. This + * makes it possible to check an object at the same time for being a vector + * or a weak vector by comparing its tc7 code with that bit masked (using + * the TYP7S macro). Two more special tc7-codes are of interest: ports and + * smobs in fact each represent collections of types, which are subdivided + * using tc16-codes. + * + * tc16 (for tc7==scm_tc7_smob): + * The largest part of the space of smob types is not subdivided in a + * predefined way, since smobs can be added arbitrarily by user C code. + * However, while Guile also defines a number of smob types throughout, + * there are four smob types for which Guile assumes that they are declared + * first and thus get known-in-advance tc16-codes. These are + * scm_tc_free_cell, scm_tc16_big, scm_tc16_real and scm_tc16_complex. The + * reason of requiring fixed tc16-codes for these types is performance. For + * the same reason, scm_tc16_real and scm_tc16_complex are given tc16-codes + * that only differ in one bit: This way, checking if an object is an + * inexact number can be done quickly (using the TYP16S macro) */ -/* {Non-immediate values.} - * - * If X is non-immediate, it is necessary to look at SCM_CAR (X) to - * figure out Xs type. X may be a cons pair, in which case the value - * SCM_CAR (x) will be either an immediate or non-immediate value. X - * may be something other than a cons pair, in which case the value - * SCM_CAR (x) will be a non-object value. - * - * All immediates and non-immediates have a 0 in bit 0. We - * additionally preserve the invariant that all non-object values - * stored in the SCM_CAR of a non-immediate object have a 1 in bit 1: - */ +/* Checking if a SCM variable holds an immediate or a non-immediate object: + * This check can either be performed by checking for tc3==000 or tc3==00x, + * since for a SCM variable it is known that tc1==0. */ +#define SCM_IMP(x) (6 & SCM_UNPACK (x)) +#define SCM_NIMP(x) (!SCM_IMP (x)) + +/* Checking if a SCM variable holds an immediate integer: See numbers.h for + * the definition of the following macros: SCM_I_FIXNUM_BIT, + * SCM_MOST_POSITIVE_FIXNUM, SCM_INUMP, SCM_MAKINUM, SCM_INUM. */ + +/* Checking if a SCM variable holds a pair (for historical reasons, in Guile + * also known as a cons-cell): This is done by first checking that the SCM + * variable holds a non-immediate, and second, by checking that tc1==0 holds + * for the SCM_CELL_TYPE of the SCM variable. */ #define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0)) #define SCM_NCONSP(x) (!SCM_CONSP (x)) -/* See numbers.h for macros relating to immediate integers. - */ +/* Definitions for tc2: */ #define scm_tc2_int 2 + +/* Definitions for tc3: */ + #define SCM_ITAG3(x) (7 & SCM_UNPACK (x)) #define SCM_TYP3(x) (7 & SCM_CELL_TYPE (x)) + #define scm_tc3_cons 0 #define scm_tc3_struct 1 #define scm_tc3_int_1 (scm_tc2_int + 0) @@ -288,23 +412,12 @@ typedef unsigned long scm_t_bits; #define scm_tc3_tc7_2 7 -/* - * Do not change the three bit tags. - */ - +/* Definitions for tc7: */ #define SCM_ITAG7(x) (127 & SCM_UNPACK (x)) #define SCM_TYP7(x) (0x7f & SCM_CELL_TYPE (x)) #define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CELL_TYPE (x)) - -#define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x)) -#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) - -#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag)) - - - #define scm_tc7_symbol 5 #define scm_tc7_variable 7 @@ -317,8 +430,8 @@ typedef unsigned long scm_t_bits; /* Many of the following should be turned * into structs or smobs. We need back some - * of these 7 bit tags! - */ + * of these 7 bit tags! */ + #define scm_tc7_pws 31 #if SCM_HAVE_ARRAYS @@ -348,30 +461,29 @@ typedef unsigned long scm_t_bits; #define scm_tc7_lsubr_2 117 #define scm_tc7_lsubr 119 - -/* There are 256 port subtypes. - */ +/* There are 256 port subtypes. */ #define scm_tc7_port 125 - /* There are 256 smob subtypes. [**] If you change scm_tc7_smob, you must * also change the places it is hard coded in this file and possibly others. * Dirk:FIXME:: Any hard coded reference to scm_tc7_smob must be replaced by a - * symbolic reference. - */ + * symbolic reference. */ #define scm_tc7_smob 127 /* DO NOT CHANGE [**] */ -/* Here are the first four smob subtypes. - */ +/* Definitions for tc16: */ +#define SCM_TYP16(x) (0xffff & SCM_CELL_TYPE (x)) +#define SCM_TYP16S(x) (0xfeff & SCM_CELL_TYPE (x)) + +#define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag)) + +/* Here are the first four smob subtypes. */ /* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell - * the conservative marker not to trace it. - */ + * the conservative marker not to trace it. */ #define scm_tc_free_cell (scm_tc7_smob + 0 * 256L) -/* Smob type 1 to 3 (note the dependency on the predicate SCM_NUMP) - */ +/* Smob type 1 to 3 (note the dependency on the predicate SCM_NUMP) */ #define scm_tc16_big (scm_tc7_smob + 1 * 256L) #define scm_tc16_real (scm_tc7_smob + 2 * 256L) #define scm_tc16_complex (scm_tc7_smob + 3 * 256L) From 6b412e917104fb1b148083c3d061acb351259137 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 6 Sep 2003 08:50:26 +0000 Subject: [PATCH 073/109] * eq.c (scm_eqv_p, scm_equal_p): Removed uses of SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. * eq.c (scm_eqv_p, scm_equal_p): Reordered comparisons from 0.0==some_expression to some_expression==0.0. The latter is better readable. The former is preferred by some people, since it leads to a compiler error when confusing == with =. However, when using gcc, a warning will be issued if in an if-statement an assigment appears. Since many Guile developers are using gcc, such errors will not remain unnoticed anyway. We can therefore focus on better readability. --- libguile/ChangeLog | 14 ++++++++++++++ libguile/eq.c | 26 +++++++++++++------------- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 1bacc8496..18d07d8f4 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,17 @@ +2003-09-06 Dirk Herrmann + + * eq.c (scm_eqv_p, scm_equal_p): Removed uses of + SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. + + * eq.c (scm_eqv_p, scm_equal_p): Reordered comparisons from + 0.0==some_expression to some_expression==0.0. The latter is + better readable. The former is preferred by some people, since it + leads to a compiler error when confusing == with =. However, when + using gcc, a warning will be issued if in an if-statement an + assigment appears. Since many Guile developers are using gcc, + such errors will not remain unnoticed anyway. We can therefore + focus on better readability. + 2003-09-04 Dirk Herrmann * tags.h: Added description of Guile's type system. Removed some diff --git a/libguile/eq.c b/libguile/eq.c index 7068eb31e..676df3ed1 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,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 @@ -80,15 +80,15 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { /* treat mixes of real and complex types specially */ - if (SCM_SLOPPY_INEXACTP (x)) + if (SCM_INEXACTP (x)) { - if (SCM_SLOPPY_REALP (x)) - return SCM_BOOL (SCM_SLOPPY_COMPLEXP (y) + if (SCM_REALP (x)) + return SCM_BOOL (SCM_COMPLEXP (y) && real_eqv (SCM_REAL_VALUE (x), SCM_COMPLEX_REAL (y)) - && 0.0 == SCM_COMPLEX_IMAG (y)); + && SCM_COMPLEX_IMAG (y) == 0.0); else - return SCM_BOOL (SCM_SLOPPY_REALP (y) + return SCM_BOOL (SCM_REALP (y) && real_eqv (SCM_COMPLEX_REAL (x), SCM_REAL_VALUE (y)) && SCM_COMPLEX_IMAG (x) == 0.0); @@ -98,8 +98,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr, if (SCM_NUMP (x)) { if (SCM_BIGP (x)) { - return SCM_BOOL (0 == scm_i_bigcmp (x, y)); - } else if (SCM_SLOPPY_REALP (x)) { + return SCM_BOOL (scm_i_bigcmp (x, y) == 0); + } else if (SCM_REALP (x)) { return SCM_BOOL (real_eqv (SCM_REAL_VALUE (x), SCM_REAL_VALUE (y))); } else { /* complex */ return SCM_BOOL (real_eqv (SCM_COMPLEX_REAL (x), @@ -149,14 +149,14 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, if (SCM_CELL_TYPE (x) != SCM_CELL_TYPE (y)) { /* treat mixes of real and complex types specially */ - if (SCM_SLOPPY_INEXACTP (x)) + if (SCM_INEXACTP (x)) { - if (SCM_SLOPPY_REALP (x)) - return SCM_BOOL (SCM_SLOPPY_COMPLEXP (y) + if (SCM_REALP (x)) + return SCM_BOOL (SCM_COMPLEXP (y) && SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y) - && 0.0 == SCM_COMPLEX_IMAG (y)); + && SCM_COMPLEX_IMAG (y) == 0.0); else - return SCM_BOOL (SCM_SLOPPY_REALP (y) + return SCM_BOOL (SCM_REALP (y) && SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y) && SCM_COMPLEX_IMAG (x) == 0.0); } From 0d5e348022e1da4d51a7ddf2b7a3412197c507ac Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sat, 6 Sep 2003 09:17:29 +0000 Subject: [PATCH 074/109] * numbers.h (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Removed uses of SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. * numbers.h, deprecated.h (SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP, SCM_SLOPPY_COMPLEXP): Deprecated and moved from numbers.h to deprecated.h. --- NEWS | 12 ++++++++++++ libguile/ChangeLog | 9 +++++++++ libguile/deprecated.h | 7 +++++++ libguile/numbers.h | 9 +++------ 4 files changed, 31 insertions(+), 6 deletions(-) diff --git a/NEWS b/NEWS index e9adf4ffd..a0f3a9e98 100644 --- a/NEWS +++ b/NEWS @@ -630,6 +630,18 @@ Guile always defines scm_t_timespec +** The macro SCM_SLOPPY_INEXACTP has been deprecated. + +Use SCM_INEXACTP instead. + +** The macro SCM_SLOPPY_REALP has been deprecated. + +Use SCM_REALP instead. + +** The macro SCM_SLOPPY_COMPLEXP has been deprecated. + +Use SCM_COMPLEXP instead. + ** The preprocessor define USE_THREADS has been deprecated. Going forward, assume that the thread API is always present. diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 18d07d8f4..a00254ddd 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,12 @@ +2003-09-06 Dirk Herrmann + + * numbers.h (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Removed uses + of SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP and SCM_SLOPPY_COMPLEXP. + + * numbers.h, deprecated.h (SCM_SLOPPY_INEXACTP, SCM_SLOPPY_REALP, + SCM_SLOPPY_COMPLEXP): Deprecated and moved from numbers.h to + deprecated.h. + 2003-09-06 Dirk Herrmann * eq.c (scm_eqv_p, scm_equal_p): Removed uses of diff --git a/libguile/deprecated.h b/libguile/deprecated.h index ec0901d37..c16ad93a2 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -27,6 +27,13 @@ #if (SCM_ENABLE_DEPRECATED == 1) +/* From numbers.h: Macros checking for types, but avoiding a redundant check + * for !SCM_IMP. These were deprecated in guile 1.7.0 on 2003-09-06. */ +#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) +#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real) +#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex) + + /* From eval.h: Macros for handling ilocs. These were deprecated in guile * 1.7.0 on 2003-06-04. */ #define SCM_ILOC00 SCM_MAKE_ITAG8(0L, scm_tc8_iloc) diff --git a/libguile/numbers.h b/libguile/numbers.h index c46bfe816..4172c703e 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -121,12 +121,9 @@ /* Numbers */ -#define SCM_SLOPPY_INEXACTP(x) (SCM_TYP16S (x) == scm_tc16_real) -#define SCM_SLOPPY_REALP(x) (SCM_TYP16 (x) == scm_tc16_real) -#define SCM_SLOPPY_COMPLEXP(x) (SCM_TYP16 (x) == scm_tc16_complex) -#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_SLOPPY_INEXACTP(x)) -#define SCM_REALP(x) (!SCM_IMP (x) && SCM_SLOPPY_REALP(x)) -#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_SLOPPY_COMPLEXP(x)) +#define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_TYP16S (x) == scm_tc16_real) +#define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real) +#define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex) #define SCM_REAL_VALUE(x) (((scm_t_double *) SCM2PTR (x))->real) #define SCM_COMPLEX_MEM(x) ((scm_t_complex *) SCM_CELL_WORD_1 (x)) From 2b2c6fca20f959db6e58e6638059f74a817f4fea Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 14:13:48 +0000 Subject: [PATCH 075/109] Use "extern inline" only with GCC. Use "static inline" else. --- libguile/inline.h | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/libguile/inline.h b/libguile/inline.h index 393865233..0a3c8ad75 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -3,7 +3,7 @@ #ifndef SCM_INLINE_H #define SCM_INLINE_H -/* Copyright (C) 2001, 2002 Free Software Foundation, Inc. +/* Copyright (C) 2001, 2002, 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 @@ -53,7 +53,12 @@ extern unsigned scm_newcell_count; #if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H /* definitely inlining */ -extern SCM_C_INLINE +#ifdef __GNUC__ +extern +#else +static +#endif +SCM_C_INLINE #endif SCM scm_cell (scm_t_bits car, scm_t_bits cdr) @@ -145,7 +150,12 @@ scm_cell (scm_t_bits car, scm_t_bits cdr) #if defined SCM_C_INLINE && ! defined SCM_INLINE_C_INCLUDING_INLINE_H /* definitely inlining */ -extern SCM_C_INLINE +#ifdef __GNUC__ +extern +#else +static +#endif +SCM_C_INLINE #endif SCM scm_double_cell (scm_t_bits car, scm_t_bits cbr, From 62f548e16cd76b8c60ee9b8602db0635b9dcb73f Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 14:14:05 +0000 Subject: [PATCH 076/109] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index a00254ddd..58f9ac7c2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-12 Marius Vollmer + + * inline.h: Use "extern inline" only with GCC. Use "static + inline" else. + 2003-09-06 Dirk Herrmann * numbers.h (SCM_INEXACTP, SCM_REALP, SCM_COMPLEXP): Removed uses From 6dc1cd1eec346af86dad94c450897ef1bb03d8d5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:11:09 +0000 Subject: [PATCH 077/109] (scm_module_reverse_lookup): Check that the obarray really is a hashtable and do nothing if not. --- libguile/modules.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/modules.c b/libguile/modules.c index fd13c516b..f034426ab 100644 --- a/libguile/modules.c +++ b/libguile/modules.c @@ -568,6 +568,9 @@ scm_module_reverse_lookup (SCM module, SCM variable) obarray = SCM_MODULE_OBARRAY (module); } + if (!SCM_HASHTABLE_P (obarray)) + return SCM_BOOL_F; + /* XXX - We do not use scm_hash_fold here to avoid searching the whole obarray. We should have a scm_hash_find procedure. */ From cdc5f67652be9af267161b944000f361510f5f96 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:11:59 +0000 Subject: [PATCH 078/109] (scm_tc16_hashtable): Added "extern" declaration. --- libguile/hashtab.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 474d7eda8..96d3e8715 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -31,6 +31,8 @@ #define SCM_HASHTABLEF_WEAK_CAR SCM_WVECTF_WEAK_KEY #define SCM_HASHTABLEF_WEAK_CDR SCM_WVECTF_WEAK_VALUE +extern scm_t_bits scm_tc16_hashtable; + #define SCM_HASHTABLE_P(x) SCM_TYP16_PREDICATE (scm_tc16_hashtable, x) #define SCM_VALIDATE_HASHTABLE(pos, arg) \ SCM_MAKE_VALIDATE_MSG (pos, arg, HASHTABLE_P, "hash-table") From 8da867bfc6338f0992690a9c6a8bbcdee4b0fd13 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:14:25 +0000 Subject: [PATCH 079/109] (format:error): Use 'format:format' instead of 'format' since the latter will lock the mutex again that we have already locked. (format:format-work): Flag multiple '#' as an error. --- ice-9/format.scm | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/ice-9/format.scm b/ice-9/format.scm index 486dc7277..55139365f 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -112,7 +112,8 @@ (let ((format-string (cadr format-args))) (if (not (zero? format:arg-pos)) (set! format:arg-pos (- format:arg-pos 1))) - (format port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ + (format:format + port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ ~{~a ~}===>~{~a ~})~% " (car format:args) (substring format-string 0 format:pos) @@ -120,10 +121,10 @@ (string-length format-string)) (list-head (cddr format:args) format:arg-pos) (list-tail (cddr format:args) format:arg-pos))) - (format port - "~%FORMAT: error with call: (format~{ ~a~})~% " - format:args)) - (apply format port args) + (format:format port + "~%FORMAT: error with call: (format~{ ~a~})~% " + format:args)) + (apply format:format port args) (newline port) (set! format:error format:error-save) (set! format:error-continuation error-continuation) @@ -737,6 +738,7 @@ (set! param-value-found #t) (tilde-dispatch)) ((#\#) ; Parameter is number of remaining args + (if param-value-found (format:error "misplaced '#'")) (if modifier (format:error "misplaced modifier")) (set! params (append params (list (length (rest-args))))) (set! param-value-found #t) From eb84efa17104d5c3d7636e33524fbefa9e65bf05 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:16:42 +0000 Subject: [PATCH 080/109] (make-autoload-interface): Use a proper hashtable as the obarray, not an empty vector. (make-module): Always construct a hashtable for the obarray, even for empty ones. --- ice-9/boot-9.scm | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index afdaec18d..e3620e038 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -975,8 +975,7 @@ (error "Lazy-binder expected to be a procedure or #f." binder)) - (let ((module (module-constructor (and (not (zero? size)) - (make-hash-table size)) + (let ((module (module-constructor (make-hash-table size) uses binder #f #f #f #f #f #f '() (make-weak-value-hash-table 31) @@ -1878,7 +1877,7 @@ ;; Replace autoload-interface with interface (set-car! (memq a (module-uses module)) i) (module-local-variable i sym)))))) - (module-constructor '#() '() b #f #f name 'autoload #f #f + (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f #f '() (make-weak-value-hash-table 31) 0))) ;;; {Compiled module} From 50e0ba57dac44b06978a0592572bbeea5ef7473d Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:16:56 +0000 Subject: [PATCH 081/109] *** empty log message *** --- ice-9/ChangeLog | 12 ++++++++++++ libguile/ChangeLog | 5 +++++ 2 files changed, 17 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index e5a51af18..cae0492fe 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,15 @@ +2003-09-12 Marius Vollmer + + * boot-9.scm (make-autoload-interface): Use a proper hashtable as + the obarray, not an empty vector. + (make-module): Always construct a hashtable for the obarray, even + for empty ones. + + * format.scm (format:error): Use 'format:format' instead of + 'format' since the latter will lock the mutex again that we have + already locked. + (format:format-work): Flag multiple '#' as an error. + 2003-08-17 Kevin Ryde * boot-9.scm (while): Use a new key dynamically for each loop, so diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 58f9ac7c2..23f3fe2fb 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,10 @@ 2003-09-12 Marius Vollmer + * hashtab.h (scm_tc16_hashtable): Added "extern" declaration. + + * modules.c (scm_module_reverse_lookup): Check that the obarray + really is a hashtable and do nothing if not. + * inline.h: Use "extern inline" only with GCC. Use "static inline" else. From 189b66ba872f3e1e5464941a478b412fc302ff4b Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:42:29 +0000 Subject: [PATCH 082/109] (SCM_FENCE): Use __memory_barrier with the Intel compiler on IA64. --- libguile/__scm.h | 2 ++ 1 file changed, 2 insertions(+) diff --git a/libguile/__scm.h b/libguile/__scm.h index bac759762..395cedee4 100644 --- a/libguile/__scm.h +++ b/libguile/__scm.h @@ -440,6 +440,8 @@ do { \ are implicitly volatile. */ #ifdef __GNUC__ #define SCM_FENCE asm /* volatile */ ("") +#elif defined (__INTEL_COMPILER) && defined (__ia64) +#define SCM_FENCE __memory_barrier() #else #define SCM_FENCE #endif From 97a61c5f91dc2524bac085a373890543a3fb21f5 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Fri, 12 Sep 2003 15:43:04 +0000 Subject: [PATCH 083/109] *** empty log message *** --- libguile/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 23f3fe2fb..9d0b16109 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,5 +1,8 @@ 2003-09-12 Marius Vollmer + * __scm.h (SCM_FENCE): Use __memory_barrier with the Intel + compiler on IA64. + * hashtab.h (scm_tc16_hashtable): Added "extern" declaration. * modules.c (scm_module_reverse_lookup): Check that the obarray From 833fc2f186a52c9b4180fcd215e7faae626bbb80 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 12 Sep 2003 23:35:54 +0000 Subject: [PATCH 084/109] (file-exists?): Use stat rather than access?, so as to follow the effective UID/GID not the real ID. file-exists? is normally be used as a prelude to opening or some other operation, and it's the effective ID which will apply there. Emacs file-exists-p uses stat, presumably for the the same reason. --- ice-9/boot-9.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index e3620e038..5ec9b3234 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -407,10 +407,12 @@ (if (provided? 'socket) (primitive-load-path "ice-9/networking.scm")) +;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in +;; C where all that's needed is to inspect the return from stat(). (define file-exists? (if (provided? 'posix) (lambda (str) - (access? str F_OK)) + (->bool (false-if-exception (stat str)))) (lambda (str) (let ((port (catch 'system-error (lambda () (open-file str OPEN_READ)) (lambda args #f)))) From 7743d628c6a04b396703451d868c14c50047dfb6 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 12 Sep 2003 23:47:35 +0000 Subject: [PATCH 085/109] *** empty log message *** --- ice-9/ChangeLog | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index cae0492fe..20e62b71d 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,11 @@ +2003-09-13 Kevin Ryde + + * boot-9.scm (file-exists?): Use stat rather than access?, so as to + follow the effective UID/GID not the real ID. file-exists? is + normally be used as a prelude to opening or some other operation, and + it's the effective ID which will apply there. Emacs file-exists-p + uses stat, presumably for the the same reason. + 2003-09-12 Marius Vollmer * boot-9.scm (make-autoload-interface): Use a proper hashtable as From eaa032c38924d177ddd34f703ea12f9a88d5f0e3 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 12 Sep 2003 23:55:03 +0000 Subject: [PATCH 086/109] (Reading): In port-column, port-line, set-port-column! and set-port-line!, port parameter must be given, there's no default to current input. --- doc/ref/scheme-io.texi | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/doc/ref/scheme-io.texi b/doc/ref/scheme-io.texi index 2ca70193e..729bad755 100644 --- a/doc/ref/scheme-io.texi +++ b/doc/ref/scheme-io.texi @@ -176,8 +176,8 @@ for further input. @deffnx {Scheme Procedure} port-line port @deffnx {C Function} scm_port_column (port) @deffnx {C Function} scm_port_line (port) -Return the current column number or line number of @var{port}, -using the current input port if none is specified. If the number is +Return the current column number or line number of @var{port}. +If the number is unknown, the result is #f. Otherwise, the result is a 0-origin integer - i.e.@: the first character of the first line is line 0, column 0. (However, when you display a file position, for example in an error @@ -190,8 +190,7 @@ what non-programmers will find most natural.) @deffnx {Scheme Procedure} set-port-line! port line @deffnx {C Function} scm_set_port_column_x (port, column) @deffnx {C Function} scm_set_port_line_x (port, line) -Set the current column or line number of @var{port}, using the -current input port if none is specified. +Set the current column or line number of @var{port}. @end deffn @node Writing From 5c3917e7f5fa22337f7988f0dd550d3cb1e4054c Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 12 Sep 2003 23:57:03 +0000 Subject: [PATCH 087/109] (File System): In stat:dev and stat:mode, clarify that both are numbers. --- doc/ref/posix.texi | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 2fee4ff9b..33f6d7ca4 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -577,15 +577,15 @@ parameter to the following procedures, all of which return integers: @deffn {Scheme Procedure} stat:dev st -The device containing the file. +The device number containing the file. @end deffn @deffn {Scheme Procedure} stat:ino st The file serial number, which distinguishes this file from all other files on the same device. @end deffn @deffn {Scheme Procedure} stat:mode st -The mode of the file. This includes file type information and -the file permission bits. See @code{stat:type} and +The mode of the file. This is an integer which incorporates file type +information and file permission bits. See also @code{stat:type} and @code{stat:perms} below. @end deffn @deffn {Scheme Procedure} stat:nlink st @@ -626,7 +626,7 @@ which case @code{stat:blocks} returns @code{#f}. @end deffn In addition, the following procedures return the information -from stat:mode in a more convenient form: +from @code{stat:mode} in a more convenient form: @deffn {Scheme Procedure} stat:type st A symbol representing the type of file. Possible values are From 957f9f622d0de2747698af20c002971903f28814 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 12 Sep 2003 23:59:30 +0000 Subject: [PATCH 088/109] (Network Address Conversion): Under IPv4, describe numeric representation in Guile, add INADDR_LOOPBACK and INADDR_BROADCAST, add commented-out INADDR_NONE. --- doc/ref/posix.texi | 23 +++++++++++++++++++++++ 1 file changed, 23 insertions(+) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 33f6d7ca4..e70357f8a 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1810,6 +1810,29 @@ between numeric and string formats. @subsubsection IPv4 Address Conversion +An IPv4 Internet address is a 4-byte value, represented in Guile as an +integer in network byte order (meaning the first byte is the most +significant in the number). + +@defvar INADDR_LOOPBACK +The address of the local host using the loopback device, ie.@: +@samp{127.0.0.1}. +@end defvar + +@defvar INADDR_BROADCAST +The broadcast address on the local network. +@end defvar + +@c INADDR_NONE is defined in the code, but serves no purpose. +@c inet_addr() returns it as an error indication, but that function +@c isn't provided, for the good reason that inet_aton() does the same +@c job and gives an unambiguous error indication. (INADDR_NONE is a +@c valid 4-byte value, in glibc it's the same as INADDR_BROADCAST.) +@c +@c @defvar INADDR_NONE +@c No address. +@c @end defvar + @deffn {Scheme Procedure} inet-aton address @deffnx {C Function} scm_inet_aton (address) Convert an IPv4 Internet address from printable string From 57066448c29997963af73c84934a5b05a94fafb4 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:01:48 +0000 Subject: [PATCH 089/109] (SRFI-1 Constructors): Add list-copy. --- doc/ref/srfi-modules.texi | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 795e5a188..887a131cf 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -215,6 +215,15 @@ index. The order in which @var{init-proc} is applied to the indices is not specified. @end deffn +@deffn {Scheme Procedure} list-copy lst +Return a new list containing the elements of the list @var{lst}. + +This function differs from the core @code{list-copy} (@pxref{List +Constructors}) in accepting improper lists too. And if @var{lst} is +not a pair at all then it's treated as the final tail of an improper +list and simply returned. +@end deffn + @deffn {Scheme Procedure} circular-list elt1 elt2 @dots{} Return a circular list containing the given arguments @var{elt1} @var{elt2} @dots{}. From eee36f210501b8492049815556c40153ba1e35da Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:09:14 +0000 Subject: [PATCH 090/109] (Reading): Add scm_c_read. (Writing): Add scm_c_write. --- doc/ref/scheme-io.texi | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/doc/ref/scheme-io.texi b/doc/ref/scheme-io.texi index 729bad755..3dc1dd4aa 100644 --- a/doc/ref/scheme-io.texi +++ b/doc/ref/scheme-io.texi @@ -120,6 +120,15 @@ Return the next character available from @var{port}, updating characters are available, the end-of-file object is returned. @end deffn +@deftypefn {C Function} size_t scm_c_read (SCM port, void *buffer, size_t size) +Read up to @var{size} bytes from @var{port} and store them in +@var{buffer}. The return value is the number of bytes actually read, +which can be less than @var{size} if end-of-file has been reached. + +Note that this function does not update @code{port-line} and +@code{port-column} below. +@end deftypefn + @rnindex peek-char @deffn {Scheme Procedure} peek-char [port] @deffnx {C Function} scm_peek_char (port) @@ -268,6 +277,13 @@ containing the formatted text. Does not add a trailing newline. Send character @var{chr} to @var{port}. @end deffn +@deftypefn {C Function} void scm_c_write (SCM port, const void *buffer, size_t size) +Write @var{size} bytes at @var{buffer} to @var{port}. + +Note that this function does not update @code{port-line} and +@code{port-column} (@pxref{Reading}). +@end deftypefn + @findex fflush @deffn {Scheme Procedure} force-output [port] @deffnx {C Function} scm_force_output (port) From c537e01bcefe6a4741f4e98a65137e2778ad2854 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:12:08 +0000 Subject: [PATCH 091/109] (Append/Reverse): Merge reverse and reverse!, describe newtail parameter for reverse!, remove confusing caveat about head becoming tail for reverse!. --- doc/ref/scheme-compound.texi | 25 +++++++++---------------- 1 file changed, 9 insertions(+), 16 deletions(-) diff --git a/doc/ref/scheme-compound.texi b/doc/ref/scheme-compound.texi index 73b1dcaee..2876017be 100644 --- a/doc/ref/scheme-compound.texi +++ b/doc/ref/scheme-compound.texi @@ -372,25 +372,18 @@ itself is not modified or used in the return. @rnindex reverse @deffn {Scheme Procedure} reverse lst +@deffnx {Scheme Procedure} reverse! lst [newtail] @deffnx {C Function} scm_reverse (lst) -Return a new list that contains the elements of @var{lst} but -in reverse order. -@end deffn +@deffnx {C Function} scm_reverse_x (lst, newtail) +Return a list comprising the elements of @var{lst}, in reverse order. -@c NJFIXME explain new_tail -@deffn {Scheme Procedure} reverse! lst [new_tail] -@deffnx {C Function} scm_reverse_x (lst, new_tail) -A destructive version of @code{reverse} (@pxref{Pairs and lists,,,r5rs, -The Revised^5 Report on Scheme}). The cdr of each cell in @var{lst} is -modified to point to the previous list element. Return a pointer to the -head of the reversed list. +@code{reverse} constructs a new list, @code{reverse!} modifies +@var{lst} in constructing its return. -Caveat: because the list is modified in place, the tail of the original -list now becomes its head, and the head of the original list now becomes -the tail. Therefore, the @var{lst} symbol to which the head of the -original list was bound now points to the tail. To ensure that the head -of the modified list is not lost, it is wise to save the return value of -@code{reverse!} +For @code{reverse!}, the optional @var{newtail} is appended to to the +result. @var{newtail} isn't reversed, it simply becomes the list +tail. For @code{scm_reverse_x}, the @var{newtail} parameter is +mandatory, but can be @code{SCM_EOL} if no further tail is required. @end deffn @node List Modification From 9f5e5b5601cfa334aaa5ea0dc33e3b3a86088f15 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:18:46 +0000 Subject: [PATCH 092/109] *** empty log message *** --- doc/ref/ChangeLog | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 795e841ed..3d10a4535 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -1,3 +1,25 @@ +2003-09-13 Kevin Ryde + + * posix.texi (File System): In stat:dev and stat:mode, clarify that + both are numbers. + + * posix.texi (Network Address Conversion): Under IPv4, describe + numeric representation in Guile, add INADDR_LOOPBACK and + INADDR_BROADCAST, add commented-out INADDR_NONE. + + * scheme-compound.texi (Append/Reverse): Merge reverse and reverse!, + describe newtail parameter for reverse!, remove confusing caveat about + head becoming tail for reverse!. + + * scheme-io.texi (Reading): In port-column, port-line, + set-port-column! and set-port-line!, port parameter must be given, + there's no default to current input. + + * scheme-io.texi (Reading): Add scm_c_read. + (Writing): Add scm_c_write. + + * srfi-modules.texi (SRFI-1 Constructors): Add list-copy. + 2003-09-03 Kevin Ryde * scheme-data.texi (Keyword Primitives): Add examples to From 85600a0f78db42f8e7cc285846e74bcb5e7813ac Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:39:16 +0000 Subject: [PATCH 093/109] (SRFI-19): Rewrite, adding descriptions of all functions, and a bit of an introduction. --- doc/ref/srfi-modules.texi | 657 ++++++++++++++++++++++++++++++-------- 1 file changed, 529 insertions(+), 128 deletions(-) diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 887a131cf..ee27bbffb 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -2361,156 +2361,557 @@ specified in the SRFI. Using it avoids the described problems. @section SRFI-19 - Time/Date Library @cindex SRFI-19 -This is an implementation of SRFI-19: Time/Date Library +This is an implementation of the SRFI-19 time/date library. The +functions and variables described here are provided by -It depends on SRFIs: 6 (@pxref{SRFI-6}), 8 (@pxref{SRFI-8}), -9 (@pxref{SRFI-9}). - -This section documents constants and procedure signatures. +@example +(use-modules (srfi srfi-19)) +@end example @menu -* SRFI-19 Constants:: -* SRFI-19 Current time and clock resolution:: -* SRFI-19 Time object and accessors:: -* SRFI-19 Time comparison procedures:: -* SRFI-19 Time arithmetic procedures:: -* SRFI-19 Date object and accessors:: -* SRFI-19 Time/Date/Julian Day/Modified Julian Day converters:: -* SRFI-19 Date to string/string to date converters:: +* SRFI-19 Introduction:: +* SRFI-19 Time:: +* SRFI-19 Date:: +* SRFI-19 Time/Date conversions:: +* SRFI-19 Date to string:: +* SRFI-19 String to date:: @end menu -@node SRFI-19 Constants -@subsection SRFI-19 Constants +@node SRFI-19 Introduction +@subsection SRFI-19 Introduction -All these are bound to their symbol names: +@cindex universal time +@cindex atomic time +@cindex UTC +@cindex TAI +This module implements time and date representations and calculations, +in various time systems, including universal time (UTC) and atomic +time (TAI). -@example - time-duration - time-monotonic - time-process - time-tai - time-thread - time-utc -@end example +For those not familiar with these time systems, TAI is based on a +fixed length second derived from oscillations of certain atoms. UTC +differs from TAI by an integral number of seconds, which is increased +or decreased at announced times to keep UTC aligned to a mean solar +day (the orbit and rotation of the earth are not quite constant). -@node SRFI-19 Current time and clock resolution -@subsection SRFI-19 Current time and clock resolution +@cindex leap second +So far, only increases in the TAI +@tex +$\leftrightarrow$ +@end tex +@ifnottex +<-> +@end ifnottex +UTC difference have been needed. Such an increase is a ``leap +second'', an extra second of TAI introduced at the end of a UTC day. +When working entirely within UTC this is never seen, every day simply +has 86400 seconds. But when converting from TAI to a UTC date, an +extra 23:59:60 is present, where normally a day would end at 23:59:59. +Effectively the UTC second from 23:59:59 to 00:00:00 has taken two TAI +seconds. -@example - (current-date . tz-offset) - (current-julian-day) - (current-modified-julian-day) - (current-time . clock-type) - (time-resolution . clock-type) -@end example +@cindex system clock +In the current implementation, the system clock is assumed to be UTC, +and a table of leap seconds in the code converts to TAI. See comments +in @file{srfi-19.scm} for how to update this table. -@node SRFI-19 Time object and accessors -@subsection SRFI-19 Time object and accessors +@cindex julian day +@cindex modified julian day +Also, for those not familiar with the terminology, a @dfn{Julian Day} +is a real number which is a count of days and fraction of a day, in +UTC, starting from -4713-01-01T12:00:00Z, ie.@: midday Monday 1 Jan +4713 B.C. And a @dfn{Modified Julian Day} is the same, but starting +from 1858-11-17T00:00:00Z, ie.@: midnight 17 November 1858 UTC. -@example - (make-time type nanosecond second) - (time? obj) - (time-type time) - (time-nanosecond time) - (time-second time) - (set-time-type! time type) - (set-time-nanosecond! time nsec) - (set-time-second! time sec) - (copy-time time) -@end example +@c The SRFI-1 spec says -4714-11-24T12:00:00Z (November 24, -4714 at +@c noon, UTC), but this is incorrect. It looks like it might have +@c arisen from the code incorrectly treating years a multiple of 100 +@c but not 400 prior to 1582 as leap years, where instead the Julian +@c calendar should be used so all multiples of 4 before 1582 are leap +@c years. -@node SRFI-19 Time comparison procedures -@subsection SRFI-19 Time comparison procedures -Args are all @code{time} values. +@node SRFI-19 Time +@subsection SRFI-19 Time +@cindex time -@example - (time<=? t1 t2) - (time=? t1 t2) - (time>? t1 t2) -@end example +A @dfn{time} object has type, seconds and nanoseconds fields +representing a point in time starting from some epoch. This is an +arbitrary point in time, not just a time of day. Although times are +represented in nanoseconds, the actual resolution may be lower. -@node SRFI-19 Time arithmetic procedures -@subsection SRFI-19 Time arithmetic procedures +The following variables hold the possible time types. For instance +@code{(current-time time-process)} would give the current CPU process +time. -The @code{foo!} variants modify in place. Time difference -is expressed in @code{time-duration} values. +@defvar time-utc +Universal Coordinated Time (UTC). +@cindex UTC +@end defvar -@example - (time-difference t1 t2) - (time-difference! t1 t2) - (add-duration time duration) - (add-duration! time duration) - (subtract-duration time duration) - (subtract-duration! time duration) - @end example +@defvar time-tai +International Atomic Time (TAI). +@cindex TAI +@end defvar -@node SRFI-19 Date object and accessors -@subsection SRFI-19 Date object and accessors +@defvar time-monotonic +Monotonic time, meaning a monotonically increasing time starting from +an unspecified epoch. -@example - (make-date nsecs seconds minutes hours - date month year offset) - (date? obj) - (date-nanosecond date) - (date-second date) - (date-minute date) - (date-hour date) - (date-day date) - (date-month date) - (date-year date) - (date-zone-offset date) - (date-year-day date) - (date-week-day date) - (date-week-number date day-of-week-starting-week) -@end example +Note that in the current implementation @code{time-monotonic} is the +same as @code{time-tai}, and unfortunately is therefore affected by +adjustments to the system clock. Perhaps this will change in the +future. +@end defvar -@node SRFI-19 Time/Date/Julian Day/Modified Julian Day converters -@subsection SRFI-19 Time/Date/Julian Day/Modified Julian Day converters +@defvar time-duration +A duration, meaning simply a difference between two times. +@end defvar -@example - (date->julian-day date) - (date->modified-julian-day date) - (date->time-monotonic date) - (date->time-tai date) - (date->time-utc date) - (julian-day->date jdn . tz-offset) - (julian-day->time-monotonic jdn) - (julian-day->time-tai jdn) - (julian-day->time-utc jdn) - (modified-julian-day->date jdn . tz-offset) - (modified-julian-day->time-monotonic jdn) - (modified-julian-day->time-tai jdn) - (modified-julian-day->time-utc jdn) - (time-monotonic->date time . tz-offset) - (time-monotonic->time-tai time-in) - (time-monotonic->time-tai! time-in) - (time-monotonic->time-utc time-in) - (time-monotonic->time-utc! time-in) - (time-tai->date time . tz-offset) - (time-tai->julian-day time) - (time-tai->modified-julian-day time) - (time-tai->time-monotonic time-in) - (time-tai->time-monotonic! time-in) - (time-tai->time-utc time-in) - (time-tai->time-utc! time-in) - (time-utc->date time . tz-offset) - (time-utc->julian-day time) - (time-utc->modified-julian-day time) - (time-utc->time-monotonic time-in) - (time-utc->time-monotonic! time-in) - (time-utc->time-tai time-in) - (time-utc->time-tai! time-in) -@end example +@defvar time-process +CPU time spent in the current process, starting from when the process +began. +@cindex process time +@end defvar -@node SRFI-19 Date to string/string to date converters -@subsection SRFI-19 Date to string/string to date converters +@defvar time-thread +CPU time spent in the current thread. Not currently implemented. +@cindex thread time +@end defvar + +@sp 1 +@defun time? obj +Return @code{#t} if @var{obj} is a time object, or @code{#f} if not. +@end defun + +@defun make-time type nanoseconds seconds +Create a time object with the given @var{type}, @var{seconds} and +@var{nanoseconds}. +@end defun + +@defun time-type time +@defunx time-nanosecond time +@defunx time-second time +@defunx set-time-type! time type +@defunx set-time-nanosecond! time nsec +@defunx set-time-second! time sec +Get or set the type, seconds or nanoseconds fields of a time object. + +@code{set-time-type!} merely changes the field, it doesn't convert the +time value. For conversions, see @ref{SRFI-19 Time/Date conversions}. +@end defun + +@defun copy-time time +Return a new time object, which is a copy of the given @var{time}. +@end defun + +@defun current-time [type] +Return the current time of the given @var{type}. The default +@var{type} is @code{time-utc}. + +Note that the name @code{current-time} conflicts with the Guile core +@code{current-time} function (@pxref{Time}). Applications wanting to +use both will need to use a different name for one of them. +@end defun + +@defun time-resolution [type] +Return the resolution, in nanoseconds, of the given time @var{type}. +The default @var{type} is @code{time-utc}. +@end defun + +@defun time<=? t1 t2 +@defunx time=? t1 t2 +@defunx time>? t1 t2 +Return @code{#t} or @code{#f} according to the respective relation +between time objects @var{t1} and @var{t2}. @var{t1} and @var{t2} +must be the same time type. +@end defun + +@defun time-difference t1 t2 +@defunx time-difference! t1 t2 +Return a time object of type @code{time-duration} representing the +period between @var{t1} and @var{t2}. @var{t1} and @var{t2} must be +the same time type. + +@code{time-difference} returns a new time object, +@code{time-difference!} may modify @var{t1} to form its return. +@end defun + +@defun add-duration time duration +@defunx add-duration! time duration +@defunx subtract-duration time duration +@defunx subtract-duration! time duration +Return a time object which is @var{time} with the given @var{duration} +added or subtracted. @var{duration} must be a time object of type +@code{time-duration}. + +@code{add-duration} and @code{subtract-duration} return a new time +object. @code{add-duration!} and @code{subtract-duration!} may modify +the given @var{time} to form their return. +@end defun + + +@node SRFI-19 Date +@subsection SRFI-19 Date +@cindex date + +A @dfn{date} object represents a date in the Gregorian calendar and a +time of day on that date in some timezone. + +The fields are year, month, day, hour, minute, second, nanoseconds and +timezone. A date object is immutable, its fields can be read but they +cannot be modified once the object is created. + +@defun date? obj +Return @code{#t} if @var{obj} is a date object, or @code{#f} if not. +@end defun + +@defun make-date nsecs seconds minutes hours date month year zone-offset +Create a new date object. +@c +@c FIXME: What can we say about the ranges of the values. The +@c current code looks it doesn't normalize, but expects then in their +@c usual range already. +@c +@end defun + +@defun date-nanosecond date +Nanoseconds, 0 to 999999999. +@end defun + +@defun date-second date +Seconds, 0 to 60. 0 to 59 is the usual range, 60 is for a leap second. +@end defun + +@defun date-minute date +Minutes, 0 to 59. +@end defun + +@defun date-hour date +Hour, 0 to 23. +@end defun + +@defun date-day date +Day of the month, 1 to 31 (or less, according to the month). +@end defun + +@defun date-month date +Month, 1 to 12. +@end defun + +@defun date-year date +Year, eg.@: 2003. +@end defun + +@defun date-zone-offset date +Time zone, an integer number of seconds east of Greenwich. +@end defun + +@defun date-year-day date +Day of the year, starting from 1 for 1st January. +@end defun + +@defun date-week-day date +Day of the week, starting from 0 for Sunday. +@end defun + +@defun date-week-number date dstartw +Week of the year, ignoring a first partial week. @var{dstartw} is the +day of the week which is taken to start a week, 0 for Sunday, 1 for +Monday, etc. +@c +@c FIXME: The spec doesn't say whether numbering starts at 0 or 1. +@c The code looks like it's 0, if that's the correct intention. +@c +@end defun + +@c The SRFI text doesn't actually give the default for tz-offset, but +@c the reference implementation has the local timezone and the +@c conversions functions all specify that, so it should be ok to +@c document it here. +@c +@defun current-date [tz-offset] +Return a date object representing the current date/time UTC. +@var{tz-offset} is seconds east of Greenwich, and defaults to the +local timezone. +@end defun + +@defun current-julian-day +@cindex julian day +Return the current Julian Day. +@end defun + +@defun current-modified-julian-day +@cindex modified julian day +Return the current Modified Julian Day. +@end defun + + +@node SRFI-19 Time/Date conversions +@subsection SRFI-19 Time/Date conversions + +@defun date->julian-day date +@defunx date->modified-julian-day date +@defunx date->time-monotonic date +@defunx date->time-tai date +@defunx date->time-utc date +@end defun +@defun julian-day->date jdn [tz-offset] +@defunx julian-day->time-monotonic jdn +@defunx julian-day->time-tai jdn +@defunx julian-day->time-utc jdn +@end defun +@defun modified-julian-day->date jdn [tz-offset] +@defunx modified-julian-day->time-monotonic jdn +@defunx modified-julian-day->time-tai jdn +@defunx modified-julian-day->time-utc jdn +@end defun +@defun time-monotonic->date time [tz-offset] +@defunx time-monotonic->time-tai time +@defunx time-monotonic->time-tai! time +@defunx time-monotonic->time-utc time +@defunx time-monotonic->time-utc! time +@end defun +@defun time-tai->date time [tz-offset] +@defunx time-tai->julian-day time +@defunx time-tai->modified-julian-day time +@defunx time-tai->time-monotonic time +@defunx time-tai->time-monotonic! time +@defunx time-tai->time-utc time +@defunx time-tai->time-utc! time +@end defun +@defun time-utc->date time [tz-offset] +@defunx time-utc->julian-day time +@defunx time-utc->modified-julian-day time +@defunx time-utc->time-monotonic time +@defunx time-utc->time-monotonic! time +@defunx time-utc->time-tai time +@defunx time-utc->time-tai! time +@sp 1 +Convert between dates, times and days of the respective types. For +instance @code{time-tai->time-utc} accepts a @var{time} object of type +@code{time-tai} and returns an object of type @code{time-utc}. + +For conversions to dates, @var{tz-offset} is seconds east of +Greenwich. The default is the local timezone. + +The @code{!} variants may modify their @var{time} argument to form +their return. The plain functions create a new object. +@end defun + +@node SRFI-19 Date to string +@subsection SRFI-19 Date to string +@cindex date to string + +@defun date->string date [format] +Convert a date to a string under the control of a format. +@var{format} should be a string containing @samp{~} escapes, which +will be expanded as per the following conversion table. The default +@var{format} is @samp{~c}, a locale-dependent date and time. + +Many of these conversion characters are the same as POSIX +@code{strftime} (@pxref{Time}), but there are some extras and some +variations. + +@multitable {MMMM} {MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM} +@item @nicode{~~} @tab literal ~ +@item @nicode{~a} @tab locale abbreviated weekday, eg.@: @samp{Sun} +@item @nicode{~A} @tab locale full weekday, eg.@: @samp{Sunday} +@item @nicode{~b} @tab locale abbreviated month, eg.@: @samp{Jan} +@item @nicode{~B} @tab locale full month, eg.@: @samp{January} +@item @nicode{~c} @tab locale date and time, eg.@: @* +@samp{Fri Jul 14 20:28:42-0400 2000} +@item @nicode{~d} @tab day of month, zero padded, @samp{01} to @samp{31} + +@c Spec says d/m/y, reference implementation says m/d/y. +@c Apparently the reference code was the intention, but would like to +@c see an errata published for the spec before contradicting it here. +@c +@c @item @nicode{~D} @tab date @nicode{~d/~m/~y} + +@item @nicode{~e} @tab day of month, blank padded, @samp{ 1} to @samp{31} +@item @nicode{~f} @tab seconds and fractional seconds, +with locale decimal point, eg.@: @samp{5.2} +@item @nicode{~h} @tab same as @nicode{~b} +@item @nicode{~H} @tab hour, 24-hour clock, zero padded, @samp{00} to @samp{23} +@item @nicode{~I} @tab hour, 12-hour clock, zero padded, @samp{01} to @samp{12} +@item @nicode{~j} @tab day of year, zero padded, @samp{001} to @samp{366} +@item @nicode{~k} @tab hour, 24-hour clock, blank padded, @samp{ 0} to @samp{23} +@item @nicode{~l} @tab hour, 12-hour clock, blank padded, @samp{ 1} to @samp{12} +@item @nicode{~m} @tab month, zero padded, @samp{01} to @samp{12} +@item @nicode{~M} @tab minute, zero padded, @samp{00} to @samp{59} +@item @nicode{~n} @tab newline +@item @nicode{~N} @tab nanosecond, zero padded, @samp{000000000} to @samp{999999999} +@item @nicode{~p} @tab locale AM or PM +@item @nicode{~r} @tab time, 12 hour clock, @samp{~I:~M:~S ~p} +@item @nicode{~s} @tab number of full seconds since ``the epoch'' in UTC +@item @nicode{~S} @tab second, zero padded @samp{00} to @samp{60} @* +(usual limit is 59, 60 is a leap second) +@item @nicode{~t} @tab horizontal tab character +@item @nicode{~T} @tab time, 24 hour clock, @samp{~H:~M:~S} +@item @nicode{~U} @tab week of year, Sunday first day of week, +@samp{00} to @samp{52} +@item @nicode{~V} @tab week of year, Monday first day of week, +@samp{01} to @samp{53} +@item @nicode{~w} @tab day of week, 0 for Sunday, @samp{0} to @samp{6} +@item @nicode{~W} @tab week of year, Monday first day of week, +@samp{00} to @samp{52} + +@c The spec has ~x as an apparent duplicate of ~W, and ~X as a locale +@c date. The reference code has ~x as the locale date and ~X as a +@c locale time. The rule is apparently that the code should be +@c believed, but would like to see an errata for the spec before +@c contradicting it here. +@c +@c @item @nicode{~x} @tab week of year, Monday as first day of week, +@c @samp{00} to @samp{53} +@c @item @nicode{~X} @tab locale date, eg.@: @samp{07/31/00} + +@item @nicode{~y} @tab year, two digits, @samp{00} to @samp{99} +@item @nicode{~Y} @tab year, full, eg.@: @samp{2003} +@item @nicode{~z} @tab time zone, RFC-822 style +@item @nicode{~Z} @tab time zone symbol (not currently implemented) +@item @nicode{~1} @tab ISO-8601 date, @samp{~Y-~m-~d} +@item @nicode{~2} @tab ISO-8601 time+zone, @samp{~k:~M:~S~z} +@item @nicode{~3} @tab ISO-8601 time, @samp{~k:~M:~S} +@item @nicode{~4} @tab ISO-8601 date/time+zone, @samp{~Y-~m-~dT~k:~M:~S~z} +@item @nicode{~5} @tab ISO-8601 date/time, @samp{~Y-~m-~dT~k:~M:~S} +@end multitable +@end defun + +Conversions @samp{~D}, @samp{~x} and @samp{~X} are not currently +described here, since the specification and reference implementation +differ. + +Currently Guile doesn't implement any localizations for the above, all +outputs are in English, and the @samp{~c} conversion is POSIX +@code{ctime} style @samp{~a ~b ~d ~H:~M:~S~z ~Y}. This may change in +the future. + + +@node SRFI-19 String to date +@subsection SRFI-19 String to date +@cindex string to date + +@c FIXME: Can we say what happens when an incomplete date is +@c converted? Ie. fields left as 0, or what? The spec seems to be +@c silent on this. + +@defun string->date input template +Convert an @var{input} string to a date under the control of a +@var{template} string. Return a newly created date object. + +Literal characters in @var{template} must match characters in +@var{input} and @samp{~} escapes must match the input forms described +in the table below. ``Skip to'' means characters up to one of the +given type are ignored, or ``no skip'' for no skipping. ``Read'' is +what's then read, and ``Set'' is the field affected in the date +object. + +For example @samp{~Y} skips input characters until a digit is reached, +at which point it expects a year and stores that to the year field of +the date. + +@multitable {MMMM} {@nicode{char-alphabetic?}} {MMMMMMMMMMMMMMMMMMMMMMMMM} {@nicode{date-zone-offset}} +@item +@tab Skip to +@tab Read +@tab Set + +@item @nicode{~~} +@tab no skip +@tab literal ~ +@tab nothing + +@item @nicode{~a} +@tab @nicode{char-alphabetic?} +@tab locale abbreviated weekday name +@tab nothing + +@item @nicode{~A} +@tab @nicode{char-alphabetic?} +@tab locale full weekday name +@tab nothing + +@c Note that the SRFI spec says that ~b and ~B don't set anything, +@c but that looks like a mistake. The reference implementation sets +@c the month field, which seems sensible and is what we describe +@c here. + +@item @nicode{~b} +@tab @nicode{char-alphabetic?} +@tab locale abbreviated month name +@tab @nicode{date-month} + +@item @nicode{~B} +@tab @nicode{char-alphabetic?} +@tab locale full month name +@tab @nicode{date-month} + +@item @nicode{~d} +@tab @nicode{char-numeric?} +@tab day of month +@tab @nicode{date-day} + +@item @nicode{~e} +@tab no skip +@tab day of month, blank padded +@tab @nicode{date-day} + +@item @nicode{~h} +@tab same as @samp{~b} + +@item @nicode{~H} +@tab @nicode{char-numeric?} +@tab hour +@tab @nicode{date-hour} + +@item @nicode{~k} +@tab no skip +@tab hour, blank padded +@tab @nicode{date-hour} + +@item @nicode{~m} +@tab @nicode{char-numeric?} +@tab month +@tab @nicode{date-month} + +@item @nicode{~M} +@tab @nicode{char-numeric?} +@tab minute +@tab @nicode{date-minute} + +@item @nicode{~S} +@tab @nicode{char-numeric?} +@tab second +@tab @nicode{date-second} + +@item @nicode{~y} +@tab no skip +@tab 2-digit year +@tab @nicode{date-year} within 50 years + +@item @nicode{~Y} +@tab @nicode{char-numeric?} +@tab year +@tab @nicode{date-year} + +@item @nicode{~z} +@tab no skip +@tab time zone +@tab date-zone-offset +@end multitable + +Notice that the weekday matching forms don't affect the date object +returned, instead the weekday will be derived from the day, month and +year. + +Currently Guile doesn't implement any localizations for the above, +month and weekday names are always expected in English. This may +change in the future. +@end defun -@example - (date->string date . format-string) - (string->date input-string template-string) -@end example @c srfi-modules.texi ends here From 89990cc656400beb5e55bb419538f0132b1c59ed Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Sat, 13 Sep 2003 00:39:44 +0000 Subject: [PATCH 094/109] *** empty log message *** --- doc/ref/ChangeLog | 3 +++ 1 file changed, 3 insertions(+) diff --git a/doc/ref/ChangeLog b/doc/ref/ChangeLog index 3d10a4535..cae68f25b 100644 --- a/doc/ref/ChangeLog +++ b/doc/ref/ChangeLog @@ -20,6 +20,9 @@ * srfi-modules.texi (SRFI-1 Constructors): Add list-copy. + * srfi-modules.texi (SRFI-19): Rewrite, adding descriptions of all + functions, and a bit of an introduction. + 2003-09-03 Kevin Ryde * scheme-data.texi (Keyword Primitives): Add examples to From 22f2cf2d9a3b0e33b5dfd42c3e1afea12d6ec01f Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Sun, 14 Sep 2003 08:07:10 +0000 Subject: [PATCH 095/109] * tags.h: Reduced the number of short instructions from 14 to 13. The typecode of the former 14th short instruction is now used to represent long instructions. Changed some comments to reflect this fact. (SCM_MAKISYM): ISYMs get a new tc7 code, namely the one that was previously used by SCM_IM_DEFINE. (SCM_IM_DEFINE): Turned into a long instruction. * eval.c (unmemocopy, SCM_CEVAL): Treat SCM_IM_DEFINE as a long instruction. * eval.c (SCM_CEVAL): Since characters and iflags have now a tc7 code that is separate from all instructions, one level of dispatch for long instructions can be eliminated. * print.c (scm_isymnames): Removed some commented code. --- libguile/ChangeLog | 21 +++++++++++++++++++++ libguile/eval.c | 46 +++++++++++++++++++++++----------------------- libguile/print.c | 4 ---- libguile/tags.h | 39 +++++++++++++++++++++++++++------------ 4 files changed, 71 insertions(+), 39 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 9d0b16109..b016cc395 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,24 @@ +2003-09-14 Dirk Herrmann + + * tags.h: Reduced the number of short instructions from 14 to 13. + The typecode of the former 14th short instruction is now used to + represent long instructions. Changed some comments to reflect + this fact. + + (SCM_MAKISYM): ISYMs get a new tc7 code, namely the one that was + previously used by SCM_IM_DEFINE. + + (SCM_IM_DEFINE): Turned into a long instruction. + + * eval.c (unmemocopy, SCM_CEVAL): Treat SCM_IM_DEFINE as a long + instruction. + + * eval.c (SCM_CEVAL): Since characters and iflags have now a tc7 + code that is separate from all instructions, one level of dispatch + for long instructions can be eliminated. + + * print.c (scm_isymnames): Removed some commented code. + 2003-09-12 Marius Vollmer * __scm.h (SCM_FENCE): Use __memory_barrier with the Intel diff --git a/libguile/eval.c b/libguile/eval.c index e84ac23f9..f4ea80630 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1618,25 +1618,23 @@ unmemocopy (SCM x, SCM env) case SCM_BIT7 (SCM_IM_SET_X): ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; - case SCM_BIT7 (SCM_IM_DEFINE): - { - SCM n; - x = SCM_CDR (x); - n = SCM_CAR (x); - z = scm_cons (n, SCM_UNSPECIFIED); - ls = scm_cons (scm_sym_define, z); - if (!SCM_NULLP (env)) - env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), - SCM_CDAR (env)), - SCM_CDR (env)); - break; - } case SCM_BIT7 (SCM_MAKISYM (0)): z = SCM_CAR (x); - if (!SCM_ISYMP (z)) - goto unmemo; switch (SCM_ISYMNUM (z)) { + case (SCM_ISYMNUM (SCM_IM_DEFINE)): + { + SCM n; + x = SCM_CDR (x); + n = SCM_CAR (x); + z = scm_cons (n, SCM_UNSPECIFIED); + ls = scm_cons (scm_sym_define, z); + if (!SCM_NULLP (env)) + env = scm_cons (scm_cons (scm_cons (n, SCM_CAAR (env)), + SCM_CDAR (env)), + SCM_CDR (env)); + break; + } case (SCM_ISYMNUM (SCM_IM_APPLY)): ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED); goto loop; @@ -1657,7 +1655,6 @@ unmemocopy (SCM x, SCM env) default: /* appease the Sun compiler god: */ ; } - unmemo: default: ls = z = unmemocar (scm_cons (unmemocopy (SCM_CAR (x), env), SCM_UNSPECIFIED), @@ -2441,20 +2438,23 @@ dispatch: RETURN (SCM_UNSPECIFIED); - case SCM_BIT7 (SCM_IM_DEFINE): /* only for internal defines */ - scm_misc_error (NULL, "Bad define placement", SCM_EOL); - - /* new syntactic forms go here. */ case SCM_BIT7 (SCM_MAKISYM (0)): proc = SCM_CAR (x); - if (!SCM_ISYMP (proc)) - goto evapply; - switch (SCM_ISYMNUM (proc)) { + case (SCM_ISYMNUM (SCM_IM_DEFINE)): + /* Top level defines are handled directly by the memoizer and thus + * will never generate memoized code with SCM_IM_DEFINE. Internal + * defines which occur at valid positions will be transformed into + * letrec expressions. Thus, whenever the executor detects + * SCM_IM_DEFINE, this must come from an internal definition at an + * illegal position. */ + scm_misc_error (NULL, "Bad define placement", SCM_EOL); + + case (SCM_ISYMNUM (SCM_IM_APPLY)): x = SCM_CDR (x); proc = EVALCAR (x, env); diff --git a/libguile/print.c b/libguile/print.c index e2544be93..af297941d 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -66,10 +66,6 @@ char *scm_isymnames[] = "#@quote", "#@set!", "#@define", -#if 0 - "#@literal-variable-ref", - "#@literal-variable-set!", -#endif "#@apply", "#@call-with-current-continuation", diff --git a/libguile/tags.h b/libguile/tags.h index 8cc293f67..4aa8764e7 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -309,18 +309,17 @@ typedef unsigned long scm_t_bits; * subdivision is of interest are the ones with tc3==100. * * tc7, tc8, tc9 (for objects with tc3==100): - * xx-0000-100: \ evaluator byte codes ('short instructions'). The byte + * 00-0000-100: \ evaluator byte codes ('short instructions'). The byte * ... } code interpreter can dispatch on them in one step based - * xx-1101-100: / on their tc7 value. - * 00-1110-100: evaluator byte codes ('long instructions'). The byte code - * interpreter needs to dispatch on them in three steps: - * The first dispatch is based on the tc7-code. The second - * dispatch checks for tc9==00-1110-100. The third dispatch - * is based on the actual byte code that is extracted from the - * upper bits. + * 00-1100-100: / on their tc7 value. + * 00-1101-100: evaluator byte codes ('long instructions'). The byte code + * interpreter needs to dispatch on them in two steps: The + * first dispatch is based on the tc7-code. The second + * dispatch is based on the actual byte code that is extracted + * from the upper bits. * x1-1110-100: characters with x as their least significant bit * 10-1110-100: various constants ('flags') - * xx-1111-100: evaluator byte codes ('ilocs') + * x1-1111-100: evaluator byte codes ('ilocs') * * * Summary of type codes on the heap @@ -515,18 +514,24 @@ enum scm_tags #define SCM_ISYMNUM(n) (SCM_UNPACK (n) >> 9) #define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)]) #define SCM_MAKSPCSYM(n) SCM_PACK (((n) << 9) + ((n) << 3) + 4L) -#define SCM_MAKISYM(n) SCM_PACK (((n) << 9) + 0x74L) +#define SCM_MAKISYM(n) SCM_PACK (((n) << 9) + 0x6cL) #define SCM_MAKIFLAG(n) SCM_PACK (((n) << 9) + 0x174L) SCM_API char *scm_isymnames[]; /* defined in print.c */ /* This table must agree with the declarations - * in repl.c: {Names of immediate symbols}. + * in print.c: {Names of immediate symbols}. * * These are used only in eval but their values * have to be allocated here. */ +/* Evaluator bytecodes (short instructions): These are uniquely identified by + * their tc7 value. This makes it possible for the evaluator to dispatch on + * them in one step. However, the type system allows for at most 13 short + * instructions. Consequently, the most frequent instructions are chosen to + * be represented as short instructions. */ + #define SCM_IM_AND SCM_MAKSPCSYM (0) #define SCM_IM_BEGIN SCM_MAKSPCSYM (1) #define SCM_IM_CASE SCM_MAKSPCSYM (2) @@ -540,7 +545,17 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_OR SCM_MAKSPCSYM (10) #define SCM_IM_QUOTE SCM_MAKSPCSYM (11) #define SCM_IM_SET_X SCM_MAKSPCSYM (12) -#define SCM_IM_DEFINE SCM_MAKSPCSYM (13) + +/* Evaluator bytecodes (long instructions): All these share a common tc7 + * value. Thus, the evaluator needs to dispatch on them in two steps. */ + +/* Evaluator bytecode for (define ...) statements. We make it a long + * instruction since the executor will see this bytecode only for a very + * limited number of times, namely once for every top-level and internal + * definition: Top-level definitions are only executed once and internal + * definitions are converted to letrec expressions. */ +#define SCM_IM_DEFINE SCM_MAKISYM (13) + #define SCM_IM_APPLY SCM_MAKISYM (14) #define SCM_IM_CONT SCM_MAKISYM (15) #define SCM_BOOL_F SCM_MAKIFLAG (16) From 2eb78d06706e3ae870fca03c4611e33fd9c4c185 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 15 Sep 2003 12:36:57 +0000 Subject: [PATCH 096/109] (scm_setgroups): Check that the gid list is not too long. Thanks to Paul Jarc! --- libguile/posix.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/libguile/posix.c b/libguile/posix.c index 2fa573f40..04113e3f2 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -253,7 +253,8 @@ SCM_DEFINE (scm_setgroups, "setgroups", 1, 0, 0, } size = ngroups * sizeof (GETGROUPS_T); - /* XXX - if (size / sizeof (GETGROUPS_T) != ngroups) out-of-range */ + if (size / sizeof (GETGROUPS_T) != ngroups) + SCM_OUT_OF_RANGE (SCM_ARG1, SCM_MAKINUM (ngroups)); groups = scm_malloc (size); for(i = 0; i < ngroups; i++) groups [i] = SCM_NUM2ULONG (1, SCM_VECTOR_REF (group_vec, i)); From eecac80630340aeb209db8ca9de8ba3a6ebc7d94 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 15 Sep 2003 12:37:16 +0000 Subject: [PATCH 097/109] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index b016cc395..f6b6c99ed 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-15 Marius Vollmer + + * posix.c (scm_setgroups): Check that the gid list is not too + long. Thanks to Paul Jarc! + 2003-09-14 Dirk Herrmann * tags.h: Reduced the number of short instructions from 14 to 13. From 093d2ca9afb2cb71317fea221466fe0946c94062 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 15 Sep 2003 13:37:50 +0000 Subject: [PATCH 098/109] (format): Rewritten as a big letrec to make it reentrant. No mutex is necessary. Thanks to Clinton Ebadi! --- ice-9/format.scm | 3332 +++++++++++++++++++++++----------------------- 1 file changed, 1690 insertions(+), 1642 deletions(-) diff --git a/ice-9/format.scm b/ice-9/format.scm index 55139365f..f10c39fcc 100644 --- a/ice-9/format.scm +++ b/ice-9/format.scm @@ -1,15 +1,15 @@ ;;;; "format.scm" Common LISP text output formatter for SLIB ;;; Written 1992-1994 by Dirk Lutzebaeck (lutzeb@cs.tu-berlin.de) ;;; Assimilated into Guile May 1999 -; -; This code is in the public domain. +;; +;; This code is in the public domain. -; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer. -; Please send error reports to bug-guile@gnu.org. -; For documentation see slib.texi and format.doc. -; For testing load formatst.scm. -; -; Version 3.0 +;; Authors of the original version (< 1.4) were Ken Dickey and Aubrey Jaffer. +;; Please send error reports to bug-guile@gnu.org. +;; For documentation see slib.texi and format.doc. +;; For testing load formatst.scm. +;; +;; Version 3.0 (define-module (ice-9 format) :use-module (ice-9 and-let-star) @@ -52,1697 +52,1745 @@ ;;; End of configuration ---------------------------------------------------- -(define format:version "3.0") -(define format:port #f) ; curr. format output port -(define format:output-col 0) ; curr. format output tty column -(define format:flush-output #f) ; flush output at end of formatting -(define format:case-conversion #f) -(define format:error-continuation #f) -(define format:args #f) -(define format:pos 0) ; curr. format string parsing position -(define format:arg-pos 0) ; curr. format argument position - ; this is global for error presentation - -; format string and char output routines on format:port - -(define (format:out-str str) - (if format:case-conversion - (display (format:case-conversion str) format:port) - (display str format:port)) - (set! format:output-col - (+ format:output-col (string-length str)))) - -(define (format:out-char ch) - (if format:case-conversion - (display (format:case-conversion (string ch)) format:port) - (write-char ch format:port)) - (set! format:output-col - (if (char=? ch #\newline) - 0 - (+ format:output-col 1)))) - -;(define (format:out-substr str i n) ; this allocates a new string -; (display (substring str i n) format:port) -; (set! format:output-col (+ format:output-col n))) - -(define (format:out-substr str i n) - (do ((k i (+ k 1))) - ((= k n)) - (write-char (string-ref str k) format:port)) - (set! format:output-col (+ format:output-col (- n i)))) - -;(define (format:out-fill n ch) ; this allocates a new string -; (format:out-str (make-string n ch))) - -(define (format:out-fill n ch) - (do ((i 0 (+ i 1))) - ((= i n)) - (write-char ch format:port)) - (set! format:output-col (+ format:output-col n))) - -; format's user error handler - -(define (format:error . args) ; never returns! - (let ((error-continuation format:error-continuation) - (format-args format:args) - (port (current-error-port))) - (set! format:error format:intern-error) - (if (and (>= (length format:args) 2) - (string? (cadr format:args))) - (let ((format-string (cadr format-args))) - (if (not (zero? format:arg-pos)) - (set! format:arg-pos (- format:arg-pos 1))) - (format:format - port "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ - ~{~a ~}===>~{~a ~})~% " - (car format:args) - (substring format-string 0 format:pos) - (substring format-string format:pos - (string-length format-string)) - (list-head (cddr format:args) format:arg-pos) - (list-tail (cddr format:args) format:arg-pos))) - (format:format port - "~%FORMAT: error with call: (format~{ ~a~})~% " - format:args)) - (apply format:format port args) - (newline port) - (set! format:error format:error-save) - (set! format:error-continuation error-continuation) - (format:abort) - (format:intern-error "format:abort does not jump to toplevel!"))) - -(define format:error-save format:error) - -(define (format:intern-error . args) ;if something goes wrong in format:error - (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) - (display " format args: ") (write format:args) (newline) - (display " error args: ") (write args) (newline) - (set! format:error format:error-save) - (format:abort)) - -(define (format:format . args) ; the formatter entry - (set! format:args args) - (set! format:arg-pos 0) - (set! format:pos 0) - (if (< (length args) 1) - (format:error "not enough arguments")) - - ;; If the first argument is a string, then that's the format string. - ;; (Scheme->C) - ;; In this case, put the argument list in canonical form. - (let ((args (if (string? (car args)) - (cons #f args) - args))) - ;; Use this canonicalized version when reporting errors. - (set! format:args args) - - (let ((destination (car args)) - (arglist (cdr args))) - (cond - ((or (and (boolean? destination) ; port output - destination) - (output-port? destination) - (number? destination)) - (format:out (cond - ((boolean? destination) (current-output-port)) - ((output-port? destination) destination) - ((number? destination) (current-error-port))) - (car arglist) (cdr arglist))) - ((and (boolean? destination) ; string output - (not destination)) - (call-with-output-string - (lambda (port) (format:out port (car arglist) (cdr arglist))))) - (else - (format:error "illegal destination `~a'" destination)))))) - -(define (format:out port fmt args) ; the output handler for a port - (set! format:port port) ; global port for output routines - (set! format:case-conversion #f) ; modifier case conversion procedure - (set! format:flush-output #f) ; ~! reset - (and-let* ((col (port-column port))) ; get current column from port - (set! format:output-col col)) - (let ((arg-pos (format:format-work fmt args)) - (arg-len (length args))) - (cond - ((< arg-pos arg-len) - (set! format:arg-pos (+ arg-pos 1)) - (set! format:pos (string-length fmt)) - (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) - ((> arg-pos arg-len) - (set! format:arg-pos (+ arg-len 1)) - (display format:arg-pos) - (format:error "~a missing argument~:p" (- arg-pos arg-len))) - (else - (if format:flush-output (force-output port)) - #t)))) - -(define format:parameter-characters - '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) - -(define (format:format-work format-string arglist) ; does the formatting work +(define (format . args) (letrec - ((format-string-len (string-length format-string)) - (arg-pos 0) ; argument position in arglist - (arg-len (length arglist)) ; number of arguments - (modifier #f) ; 'colon | 'at | 'colon-at | #f - (params '()) ; directive parameter list - (param-value-found #f) ; a directive parameter value found - (conditional-nest 0) ; conditional nesting level - (clause-pos 0) ; last cond. clause beginning char pos - (clause-default #f) ; conditional default clause string - (clauses '()) ; conditional clause string list - (conditional-type #f) ; reflects the contional modifiers - (conditional-arg #f) ; argument to apply the conditional - (iteration-nest 0) ; iteration nesting level - (iteration-pos 0) ; iteration string beginning char pos - (iteration-type #f) ; reflects the iteration modifiers - (max-iterations #f) ; maximum number of iterations - (recursive-pos-save format:pos) + ((format:version "3.0") + (format:port #f) ; curr. format output port + (format:output-col 0) ; curr. format output tty column + (format:flush-output #f) ; flush output at end of formatting + (format:case-conversion #f) + (format:args #f) + (format:pos 0) ; curr. format string parsing position + (format:arg-pos 0) ; curr. format argument position + ; this is global for error presentation + + ;; format string and char output routines on format:port - (next-char ; gets the next char from format-string - (lambda () - (let ((ch (peek-next-char))) - (set! format:pos (+ 1 format:pos)) - ch))) + (format:out-str + (lambda (str) + (if format:case-conversion + (display (format:case-conversion str) format:port) + (display str format:port)) + (set! format:output-col + (+ format:output-col (string-length str))))) - (peek-next-char - (lambda () - (if (>= format:pos format-string-len) - (format:error "illegal format string") - (string-ref format-string format:pos)))) + (format:out-char + (lambda (ch) + (if format:case-conversion + (display (format:case-conversion (string ch)) + format:port) + (write-char ch format:port)) + (set! format:output-col + (if (char=? ch #\newline) + 0 + (+ format:output-col 1))))) + + ;;(define (format:out-substr str i n) ; this allocates a new string + ;; (display (substring str i n) format:port) + ;; (set! format:output-col (+ format:output-col n))) - (one-positive-integer? - (lambda (params) - (cond - ((null? params) #f) - ((and (integer? (car params)) - (>= (car params) 0) - (= (length params) 1)) #t) - (else (format:error "one positive integer parameter expected"))))) + (format:out-substr + (lambda (str i n) + (do ((k i (+ k 1))) + ((= k n)) + (write-char (string-ref str k) format:port)) + (set! format:output-col (+ format:output-col (- n i))))) - (next-arg - (lambda () - (if (>= arg-pos arg-len) - (begin - (set! format:arg-pos (+ arg-len 1)) - (format:error "missing argument(s)"))) - (add-arg-pos 1) - (list-ref arglist (- arg-pos 1)))) + ;;(define (format:out-fill n ch) ; this allocates a new string + ;; (format:out-str (make-string n ch))) - (prev-arg - (lambda () - (add-arg-pos -1) - (if (negative? arg-pos) - (format:error "missing backward argument(s)")) - (list-ref arglist arg-pos))) + (format:out-fill + (lambda (n ch) + (do ((i 0 (+ i 1))) + ((= i n)) + (write-char ch format:port)) + (set! format:output-col (+ format:output-col n)))) - (rest-args - (lambda () - (let loop ((l arglist) (k arg-pos)) ; list-tail definition - (if (= k 0) l (loop (cdr l) (- k 1)))))) + ;; format's user error handler - (add-arg-pos - (lambda (n) - (set! arg-pos (+ n arg-pos)) - (set! format:arg-pos arg-pos))) + (format:error + (lambda args ; never returns! + (let ((format-args format:args) + (port (current-error-port))) + (set! format:error format:intern-error) + (if (and (>= (length format:args) 2) + (string? (cadr format:args))) + (let ((format-string (cadr format-args))) + (if (not (zero? format:arg-pos)) + (set! format:arg-pos (- format:arg-pos 1))) + (format port + "~%FORMAT: error with call: (format ~a \"~a<===~a\" ~ + ~{~a ~}===>~{~a ~})~% " + (car format:args) + (substring format-string 0 format:pos) + (substring format-string format:pos + (string-length format-string)) + (list-head (cddr format:args) format:arg-pos) + (list-tail (cddr format:args) format:arg-pos))) + (format port + "~%FORMAT: error with call: (format~{ ~a~})~% " + format:args)) + (apply format port args) + (newline port) + (set! format:error format:error-save) + (format:abort)))) - (anychar-dispatch ; dispatches the format-string - (lambda () - (if (>= format:pos format-string-len) - arg-pos ; used for ~? continuance - (let ((char (next-char))) - (cond - ((char=? char #\~) - (set! modifier #f) - (set! params '()) - (set! param-value-found #f) - (tilde-dispatch)) - (else - (if (and (zero? conditional-nest) - (zero? iteration-nest)) - (format:out-char char)) - (anychar-dispatch))))))) + (format:intern-error + (lambda args + ;;if something goes wrong in format:error + (display "FORMAT: INTERNAL ERROR IN FORMAT:ERROR!") (newline) + (display " format args: ") (write format:args) (newline) + (display " error args: ") (write args) (newline) + (set! format:error format:error-save) + (format:abort))) + + (format:error-save #f) - (tilde-dispatch - (lambda () - (cond - ((>= format:pos format-string-len) - (format:out-str "~") ; tilde at end of string is just output - arg-pos) ; used for ~? continuance - ((and (or (zero? conditional-nest) - (memv (peek-next-char) ; find conditional directives - (append '(#\[ #\] #\; #\: #\@ #\^) - format:parameter-characters))) - (or (zero? iteration-nest) - (memv (peek-next-char) ; find iteration directives - (append '(#\{ #\} #\: #\@ #\^) - format:parameter-characters)))) - (case (char-upcase (next-char)) + (format:format + (lambda args ; the formatter entry + (set! format:args args) + (set! format:arg-pos 0) + (set! format:pos 0) + (if (< (length args) 1) + (format:error "not enough arguments")) - ;; format directives + ;; If the first argument is a string, then that's the format string. + ;; (Scheme->C) + ;; In this case, put the argument list in canonical form. + (let ((args (if (string? (car args)) + (cons #f args) + args))) + ;; Use this canonicalized version when reporting errors. + (set! format:args args) - ((#\A) ; Any -- for humans - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #f params) - (anychar-dispatch)) - ((#\S) ; Slashified -- for parsers - (set! format:read-proof (memq modifier '(colon colon-at))) - (format:out-obj-padded (memq modifier '(at colon-at)) - (next-arg) #t params) - (anychar-dispatch)) - ((#\D) ; Decimal - (format:out-num-padded modifier (next-arg) params 10) - (anychar-dispatch)) - ((#\X) ; Hexadecimal - (format:out-num-padded modifier (next-arg) params 16) - (anychar-dispatch)) - ((#\O) ; Octal - (format:out-num-padded modifier (next-arg) params 8) - (anychar-dispatch)) - ((#\B) ; Binary - (format:out-num-padded modifier (next-arg) params 2) - (anychar-dispatch)) - ((#\R) - (if (null? params) - (format:out-obj-padded ; Roman, cardinal, ordinal numerals - #f - ((case modifier - ((at) format:num->roman) - ((colon-at) format:num->old-roman) - ((colon) format:num->ordinal) - (else format:num->cardinal)) - (next-arg)) - #f params) - (format:out-num-padded ; any Radix - modifier (next-arg) (cdr params) (car params))) - (anychar-dispatch)) - ((#\F) ; Fixed-format floating-point - (if format:floats - (format:out-fixed modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\E) ; Exponential floating-point - (if format:floats - (format:out-expon modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\G) ; General floating-point - (if format:floats - (format:out-general modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\$) ; Dollars floating-point - (if format:floats - (format:out-dollar modifier (next-arg) params) - (format:out-str (number->string (next-arg)))) - (anychar-dispatch)) - ((#\I) ; Complex numbers - (if (not format:complex-numbers) - (format:error - "complex numbers not supported by this scheme system")) - (let ((z (next-arg))) - (if (not (complex? z)) - (format:error "argument not a complex number")) - (format:out-fixed modifier (real-part z) params) - (format:out-fixed 'at (imag-part z) params) - (format:out-char #\i)) - (anychar-dispatch)) - ((#\C) ; Character - (let ((ch (if (one-positive-integer? params) - (integer->char (car params)) - (next-arg)))) - (if (not (char? ch)) (format:error "~~c expects a character")) - (case modifier - ((at) - (format:out-str (format:char->str ch))) - ((colon) - (let ((c (char->integer ch))) - (if (< c 0) - (set! c (+ c 256))) ; compensate complement impl. - (cond - ((< c #x20) ; assumes that control chars are < #x20 - (format:out-char #\^) - (format:out-char - (integer->char (+ c #x40)))) - ((>= c #x7f) - (format:out-str "#\\") - (format:out-str - (if format:radix-pref - (let ((s (number->string c 8))) - (substring s 2 (string-length s))) - (number->string c 8)))) - (else - (format:out-char ch))))) - (else (format:out-char ch)))) - (anychar-dispatch)) - ((#\P) ; Plural - (if (memq modifier '(colon colon-at)) - (prev-arg)) - (let ((arg (next-arg))) - (if (not (number? arg)) - (format:error "~~p expects a number argument")) - (if (= arg 1) - (if (memq modifier '(at colon-at)) - (format:out-char #\y)) - (if (memq modifier '(at colon-at)) - (format:out-str "ies") - (format:out-char #\s)))) - (anychar-dispatch)) - ((#\~) ; Tilde - (if (one-positive-integer? params) - (format:out-fill (car params) #\~) - (format:out-char #\~)) - (anychar-dispatch)) - ((#\%) ; Newline - (if (one-positive-integer? params) - (format:out-fill (car params) #\newline) - (format:out-char #\newline)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\&) ; Fresh line - (if (one-positive-integer? params) - (begin - (if (> (car params) 0) - (format:out-fill (- (car params) - (if (> format:output-col 0) 0 1)) - #\newline)) - (set! format:output-col 0)) - (if (> format:output-col 0) - (format:out-char #\newline))) - (anychar-dispatch)) - ((#\_) ; Space character - (if (one-positive-integer? params) - (format:out-fill (car params) #\space) - (format:out-char #\space)) - (anychar-dispatch)) - ((#\/) ; Tabulator character - (if (one-positive-integer? params) - (format:out-fill (car params) #\tab) - (format:out-char #\tab)) - (anychar-dispatch)) - ((#\|) ; Page seperator - (if (one-positive-integer? params) - (format:out-fill (car params) #\page) - (format:out-char #\page)) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\T) ; Tabulate - (format:tabulate modifier params) - (anychar-dispatch)) - ((#\Y) ; Pretty-print - (pretty-print (next-arg) format:port) - (set! format:output-col 0) - (anychar-dispatch)) - ((#\? #\K) ; Indirection (is "~K" in T-Scheme) - (cond - ((memq modifier '(colon colon-at)) - (format:error "illegal modifier in ~~?")) - ((eq? modifier 'at) - (let* ((frmt (next-arg)) - (args (rest-args))) - (add-arg-pos (format:format-work frmt args)))) - (else - (let* ((frmt (next-arg)) - (args (next-arg))) - (format:format-work frmt args)))) - (anychar-dispatch)) - ((#\!) ; Flush output - (set! format:flush-output #t) - (anychar-dispatch)) - ((#\newline) ; Continuation lines - (if (eq? modifier 'at) - (format:out-char #\newline)) - (if (< format:pos format-string-len) - (do ((ch (peek-next-char) (peek-next-char))) - ((or (not (char-whitespace? ch)) - (= format:pos (- format-string-len 1)))) - (if (eq? modifier 'colon) - (format:out-char (next-char)) - (next-char)))) - (anychar-dispatch)) - ((#\*) ; Argument jumping - (case modifier - ((colon) ; jump backwards - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (prev-arg)) - (prev-arg))) - ((at) ; jump absolute - (set! arg-pos (if (one-positive-integer? params) - (car params) 0))) - ((colon-at) - (format:error "illegal modifier `:@' in ~~* directive")) - (else ; jump forward - (if (one-positive-integer? params) - (do ((i 0 (+ i 1))) - ((= i (car params))) - (next-arg)) - (next-arg)))) - (anychar-dispatch)) - ((#\() ; Case conversion begin - (set! format:case-conversion - (case modifier - ((at) string-capitalize-first) - ((colon) string-capitalize) - ((colon-at) string-upcase) - (else string-downcase))) - (anychar-dispatch)) - ((#\)) ; Case conversion end - (if (not format:case-conversion) - (format:error "missing ~~(")) - (set! format:case-conversion #f) - (anychar-dispatch)) - ((#\[) ; Conditional begin - (set! conditional-nest (+ conditional-nest 1)) - (cond - ((= conditional-nest 1) - (set! clause-pos format:pos) - (set! clause-default #f) - (set! clauses '()) - (set! conditional-type - (case modifier - ((at) 'if-then) - ((colon) 'if-else-then) - ((colon-at) (format:error "illegal modifier in ~~[")) - (else 'num-case))) - (set! conditional-arg - (if (one-positive-integer? params) - (car params) - (next-arg))))) - (anychar-dispatch)) - ((#\;) ; Conditional separator - (if (zero? conditional-nest) - (format:error "~~; not in ~~[~~] conditional")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~;")) - (if (= conditional-nest 1) - (let ((clause-str - (cond - ((eq? modifier 'colon) - (set! clause-default #t) - (substring format-string clause-pos - (- format:pos 3))) - ((memq modifier '(at colon-at)) - (format:error "illegal modifier in ~~;")) - (else - (substring format-string clause-pos - (- format:pos 2)))))) - (set! clauses (append clauses (list clause-str))) - (set! clause-pos format:pos))) - (anychar-dispatch)) - ((#\]) ; Conditional end - (if (zero? conditional-nest) (format:error "missing ~~[")) - (set! conditional-nest (- conditional-nest 1)) - (if modifier - (format:error "no modifier allowed in ~~]")) - (if (not (null? params)) - (format:error "no parameter allowed in ~~]")) - (cond - ((zero? conditional-nest) - (let ((clause-str (substring format-string clause-pos - (- format:pos 2)))) - (if clause-default - (set! clause-default clause-str) - (set! clauses (append clauses (list clause-str))))) - (case conditional-type - ((if-then) - (if conditional-arg - (format:format-work (car clauses) - (list conditional-arg)))) - ((if-else-then) - (add-arg-pos - (format:format-work (if conditional-arg - (cadr clauses) - (car clauses)) - (rest-args)))) - ((num-case) - (if (or (not (integer? conditional-arg)) - (< conditional-arg 0)) - (format:error "argument not a positive integer")) - (if (not (and (>= conditional-arg (length clauses)) - (not clause-default))) - (add-arg-pos - (format:format-work - (if (>= conditional-arg (length clauses)) - clause-default - (list-ref clauses conditional-arg)) - (rest-args)))))))) - (anychar-dispatch)) - ((#\{) ; Iteration begin - (set! iteration-nest (+ iteration-nest 1)) - (cond - ((= iteration-nest 1) - (set! iteration-pos format:pos) - (set! iteration-type - (case modifier - ((at) 'rest-args) - ((colon) 'sublists) - ((colon-at) 'rest-sublists) - (else 'list))) - (set! max-iterations (if (one-positive-integer? params) - (car params) #f)))) - (anychar-dispatch)) - ((#\}) ; Iteration end - (if (zero? iteration-nest) (format:error "missing ~~{")) - (set! iteration-nest (- iteration-nest 1)) - (case modifier - ((colon) - (if (not max-iterations) (set! max-iterations 1))) - ((colon-at at) (format:error "illegal modifier")) - (else (if (not max-iterations) (set! max-iterations 100)))) - (if (not (null? params)) - (format:error "no parameters allowed in ~~}")) - (if (zero? iteration-nest) - (let ((iteration-str - (substring format-string iteration-pos - (- format:pos (if modifier 3 2))))) - (if (string=? iteration-str "") - (set! iteration-str (next-arg))) - (case iteration-type - ((list) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (>= i max-iterations)))))) - ((sublists) - (let ((args (next-arg)) - (args-len 0)) - (if (not (list? args)) - (format:error "expected a list argument")) - (set! args-len (length args)) - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (>= arg-pos max-iterations))) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error - "expected a list of lists argument")) - (format:format-work iteration-str sublist))))) - ((rest-args) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos - (format:format-work - iteration-str - (list-tail - args arg-pos)))) - (i 0 (+ i 1))) - ((or (>= arg-pos args-len) - (>= i max-iterations)) - arg-pos)))) - (add-arg-pos usedup-args))) - ((rest-sublists) - (let* ((args (rest-args)) - (args-len (length args)) - (usedup-args - (do ((arg-pos 0 (+ arg-pos 1))) - ((or (>= arg-pos args-len) - (>= arg-pos max-iterations)) - arg-pos) - (let ((sublist (list-ref args arg-pos))) - (if (not (list? sublist)) - (format:error "expected list arguments")) - (format:format-work iteration-str sublist))))) - (add-arg-pos usedup-args))) - (else (format:error "internal error in ~~}"))))) - (anychar-dispatch)) - ((#\^) ; Up and out - (let* ((continue - (cond - ((not (null? params)) - (not - (case (length params) - ((1) (zero? (car params))) - ((2) (= (list-ref params 0) (list-ref params 1))) - ((3) (<= (list-ref params 0) - (list-ref params 1) - (list-ref params 2))) - (else (format:error "too much parameters"))))) - (format:case-conversion ; if conversion stop conversion - (set! format:case-conversion string-copy) #t) - ((= iteration-nest 1) #t) - ((= conditional-nest 1) #t) - ((>= arg-pos arg-len) - (set! format:pos format-string-len) #f) - (else #t)))) - (if continue - (anychar-dispatch)))) + (let ((destination (car args)) + (arglist (cdr args))) + (cond + ((or (and (boolean? destination) ; port output + destination) + (output-port? destination) + (number? destination)) + (format:out (cond + ((boolean? destination) (current-output-port)) + ((output-port? destination) destination) + ((number? destination) (current-error-port))) + (car arglist) (cdr arglist))) + ((and (boolean? destination) ; string output + (not destination)) + (call-with-output-string + (lambda (port) (format:out port (car arglist) (cdr arglist))))) + (else + (format:error "illegal destination `~a'" destination))))))) - ;; format directive modifiers and parameters + (format:out ; the output handler for a port + (lambda (port fmt args) + (set! format:port port) ; global port for + ; output routines + (set! format:case-conversion #f) ; modifier case + ; conversion procedure + (set! format:flush-output #f) ; ~! reset + (and-let* ((col (port-column port))) ; get current column from port + (set! format:output-col col)) + (let ((arg-pos (format:format-work fmt args)) + (arg-len (length args))) + (cond + ((< arg-pos arg-len) + (set! format:arg-pos (+ arg-pos 1)) + (set! format:pos (string-length fmt)) + (format:error "~a superfluous argument~:p" (- arg-len arg-pos))) + ((> arg-pos arg-len) + (set! format:arg-pos (+ arg-len 1)) + (display format:arg-pos) + (format:error "~a missing argument~:p" (- arg-pos arg-len))) + (else + (if format:flush-output (force-output port)) + #t))))) - ((#\@) ; `@' modifier - (if (memq modifier '(at colon-at)) - (format:error "double `@' modifier")) - (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) - (tilde-dispatch)) - ((#\:) ; `:' modifier - (if (memq modifier '(colon colon-at)) - (format:error "double `:' modifier")) - (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) - (tilde-dispatch)) - ((#\') ; Character parameter - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (char->integer (next-char))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr - (if modifier (format:error "misplaced modifier")) - (let ((num-str-beg (- format:pos 1)) - (num-str-end format:pos)) - (do ((ch (peek-next-char) (peek-next-char))) - ((not (char-numeric? ch))) - (next-char) - (set! num-str-end (+ 1 num-str-end))) - (set! params - (append params - (list (string->number - (substring format-string - num-str-beg - num-str-end)))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\V) ; Variable parameter from next argum. - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (next-arg)))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\#) ; Parameter is number of remaining args - (if param-value-found (format:error "misplaced '#'")) - (if modifier (format:error "misplaced modifier")) - (set! params (append params (list (length (rest-args))))) - (set! param-value-found #t) - (tilde-dispatch)) - ((#\,) ; Parameter separators - (if modifier (format:error "misplaced modifier")) - (if (not param-value-found) - (set! params (append params '(#f)))) ; append empty paramtr - (set! param-value-found #f) - (tilde-dispatch)) - ((#\Q) ; Inquiry messages - (if (eq? modifier 'colon) - (format:out-str format:version) - (let ((nl (string #\newline))) - (format:out-str - (string-append - "SLIB Common LISP format version " format:version nl - " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl - " please send bug reports to `lutzeb@cs.tu-berlin.de'" - nl)))) - (anychar-dispatch)) - (else ; Unknown tilde directive - (format:error "unknown control character `~c'" - (string-ref format-string (- format:pos 1)))))) - (else (anychar-dispatch)))))) ; in case of conditional + (format:parameter-characters + '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+ #\v #\# #\')) - (set! format:pos 0) - (set! format:arg-pos 0) - (anychar-dispatch) ; start the formatting - (set! format:pos recursive-pos-save) - arg-pos)) ; return the position in the arg. list - -;; format:obj->str returns a R4RS representation as a string of an arbitrary -;; scheme object. -;; First parameter is the object, second parameter is a boolean if the -;; representation should be slashified as `write' does. -;; It uses format:char->str which converts a character into -;; a slashified string as `write' does and which is implementation dependent. -;; It uses format:iobj->str to print out internal objects as -;; quoted strings so that the output can always be processed by (read) - -(define (format:obj->str obj slashify) - (define (obj->str obj slashify visited) - (if (memq obj (cdr visited)) - (let ((n (- (list-index (cdr visited) (cdr obj))))) - (string-append "#" (number->string n) "#")) - (cond - ((string? obj) - (if slashify - (let ((obj-len (string-length obj))) - (string-append - "\"" - (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm - (if (= j obj-len) - (string-append (substring obj i j) "\"") - (let ((c (string-ref obj j))) - (if (or (char=? c #\\) - (char=? c #\")) - (string-append (substring obj i j) "\\" - (loop j (+ j 1))) - (loop i (+ j 1)))))))) - obj)) - - ((boolean? obj) (if obj "#t" "#f")) - - ((number? obj) (number->string obj)) - - ((symbol? obj) - (if format:symbol-case-conv - (format:symbol-case-conv (symbol->string obj)) - (symbol->string obj))) - - ((char? obj) - (if slashify - (format:char->str obj) - (string obj))) - - ((null? obj) "()") - - ((input-port? obj) - (format:iobj->str obj)) - - ((output-port? obj) - (format:iobj->str obj)) - - ((pair? obj) - (string-append "(" - (let loop ((obj-list obj) - (visited visited) - (offset 0) - (prefix "")) - (cond ((null? (cdr obj-list)) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)))) - ((memq (cdr obj-list) visited) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " . #" - (number->string - (- offset - (list-index visited (cdr obj-list)))) - "#")) - ((pair? (cdr obj-list)) - (loop (cdr obj-list) - (cons (cdr obj-list) visited) - (+ 1 offset) - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " "))) - (else - (string-append - prefix - (obj->str (car obj-list) - #t - (cons (car obj-list) visited)) - " . " - (obj->str (cdr obj-list) - #t - (cons (cdr obj-list) visited)))))) - ")")) - - ((vector? obj) - (string-append "#" (obj->str (vector->list obj) #t visited))) - - (else ; only objects with an #<...> - (format:iobj->str obj))))) ; representation should fall in here - (obj->str obj slashify (list obj))) - -;; format:iobj->str reveals the implementation dependent representation of -;; #<...> objects with the use of display and call-with-output-string. -;; If format:read-proof is set to #t the resulting string is additionally -;; set into string quotes. - -(define format:read-proof #f) - -(define (format:iobj->str iobj) - (if (or format:read-proof - format:iobj-case-conv) - (string-append - (if format:read-proof "\"" "") - (if format:iobj-case-conv - (format:iobj-case-conv - (call-with-output-string (lambda (p) (display iobj p)))) - (call-with-output-string (lambda (p) (display iobj p)))) - (if format:read-proof "\"" "")) - (call-with-output-string (lambda (p) (display iobj p))))) - - -;; format:char->str converts a character into a slashified string as -;; done by `write'. The procedure is dependent on the integer -;; representation of characters and assumes a character number according to -;; the ASCII character set. - -(define (format:char->str ch) - (let ((int-rep (char->integer ch))) - (if (< int-rep 0) ; if chars are [-128...+127] - (set! int-rep (+ int-rep 256))) - (string-append - "#\\" - (cond - ((char=? ch #\newline) "newline") - ((and (>= int-rep 0) (<= int-rep 32)) - (vector-ref format:ascii-non-printable-charnames int-rep)) - ((= int-rep 127) "del") - ((>= int-rep 128) ; octal representation - (if format:radix-pref - (let ((s (number->string int-rep 8))) - (substring s 2 (string-length s))) - (number->string int-rep 8))) - (else (string ch)))))) - -(define format:space-ch (char->integer #\space)) -(define format:zero-ch (char->integer #\0)) - -(define (format:par pars length index default name) - (if (> length index) - (let ((par (list-ref pars index))) - (if par - (if name - (if (< par 0) - (format:error - "~s parameter must be a positive integer" name) - par) - par) - default)) - default)) - -(define (format:out-obj-padded pad-left obj slashify pars) - (if (null? pars) - (format:out-str (format:obj->str obj slashify)) - (let ((l (length pars))) - (let ((mincol (format:par pars l 0 0 "mincol")) - (colinc (format:par pars l 1 1 "colinc")) - (minpad (format:par pars l 2 0 "minpad")) - (padchar (integer->char - (format:par pars l 3 format:space-ch #f))) - (objstr (format:obj->str obj slashify))) - (if (not pad-left) - (format:out-str objstr)) - (do ((objstr-len (string-length objstr)) - (i minpad (+ i colinc))) - ((>= (+ objstr-len i) mincol) - (format:out-fill i padchar))) - (if pad-left - (format:out-str objstr)))))) - -(define (format:out-num-padded modifier number pars radix) - (if (not (integer? number)) (format:error "argument not an integer")) - (let ((numstr (number->string number radix))) - (if (and format:radix-pref (not (= radix 10))) - (set! numstr (substring numstr 2 (string-length numstr)))) - (if (and (null? pars) (not modifier)) - (format:out-str numstr) - (let ((l (length pars)) - (numstr-len (string-length numstr))) - (let ((mincol (format:par pars l 0 #f "mincol")) - (padchar (integer->char - (format:par pars l 1 format:space-ch #f))) - (commachar (integer->char - (format:par pars l 2 (char->integer #\,) #f))) - (commawidth (format:par pars l 3 3 "commawidth"))) - (if mincol - (let ((numlen numstr-len)) ; calc. the output len of number - (if (and (memq modifier '(at colon-at)) (> number 0)) - (set! numlen (+ numlen 1))) - (if (memq modifier '(colon colon-at)) - (set! numlen (+ (quotient (- numstr-len - (if (< number 0) 2 1)) - commawidth) - numlen))) - (if (> mincol numlen) - (format:out-fill (- mincol numlen) padchar)))) - (if (and (memq modifier '(at colon-at)) - (> number 0)) - (format:out-char #\+)) - (if (memq modifier '(colon colon-at)) ; insert comma character - (let ((start (remainder numstr-len commawidth)) - (ns (if (< number 0) 1 0))) - (format:out-substr numstr 0 start) - (do ((i start (+ i commawidth))) - ((>= i numstr-len)) - (if (> i ns) - (format:out-char commachar)) - (format:out-substr numstr i (+ i commawidth)))) - (format:out-str numstr))))))) - -(define (format:tabulate modifier pars) - (let ((l (length pars))) - (let ((colnum (format:par pars l 0 1 "colnum")) - (colinc (format:par pars l 1 1 "colinc")) - (padch (integer->char (format:par pars l 2 format:space-ch #f)))) - (case modifier - ((colon colon-at) - (format:error "unsupported modifier for ~~t")) - ((at) ; relative tabulation - (format:out-fill - (if (= colinc 0) - colnum ; colnum = colrel - (do ((c 0 (+ c colinc)) - (col (+ format:output-col colnum))) - ((>= c col) - (- c format:output-col)))) - padch)) - (else ; absolute tabulation - (format:out-fill - (cond - ((< format:output-col colnum) - (- colnum format:output-col)) - ((= colinc 0) - 0) - (else - (do ((c colnum (+ c colinc))) - ((>= c format:output-col) - (- c format:output-col))))) - padch)))))) - - -;; roman numerals (from dorai@cs.rice.edu). - -(define format:roman-alist - '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) - (10 #\X) (5 #\V) (1 #\I))) - -(define format:roman-boundary-values - '(100 100 10 10 1 1 #f)) - -(define format:num->old-roman - (lambda (n) - (if (and (integer? n) (>= n 1)) - (let loop ((n n) - (romans format:roman-alist) - (s '())) - (if (null? romans) (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans))) - (do ((q (quotient n roman-val) (- q 1)) - (s s (cons roman-dgt s))) - ((= q 0) - (loop (remainder n roman-val) - (cdr romans) s)))))) - (format:error "only positive integers can be romanized")))) - -(define format:num->roman - (lambda (n) - (if (and (integer? n) (> n 0)) - (let loop ((n n) - (romans format:roman-alist) - (boundaries format:roman-boundary-values) - (s '())) - (if (null? romans) - (list->string (reverse s)) - (let ((roman-val (caar romans)) - (roman-dgt (cadar romans)) - (bdry (car boundaries))) - (let loop2 ((q (quotient n roman-val)) - (r (remainder n roman-val)) - (s s)) - (if (= q 0) - (if (and bdry (>= r (- roman-val bdry))) - (loop (remainder r bdry) (cdr romans) - (cdr boundaries) - (cons roman-dgt - (append - (cdr (assv bdry romans)) - s))) - (loop r (cdr romans) (cdr boundaries) s)) - (loop2 (- q 1) r (cons roman-dgt s))))))) - (format:error "only positive integers can be romanized")))) - -;; cardinals & ordinals (from dorai@cs.rice.edu) - -(define format:cardinal-ones-list - '(#f "one" "two" "three" "four" "five" - "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" - "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" - "nineteen")) - -(define format:cardinal-tens-list - '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" - "ninety")) - -(define format:num->cardinal999 - (lambda (n) - ;this procedure is inspired by the Bruno Haible's CLisp - ;function format-small-cardinal, which converts numbers - ;in the range 1 to 999, and is used for converting each - ;thousand-block in a larger number - (let* ((hundreds (quotient n 100)) - (tens+ones (remainder n 100)) - (tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (append - (if (> hundreds 0) - (append - (string->list - (list-ref format:cardinal-ones-list hundreds)) - (string->list" hundred") - (if (> tens+ones 0) '(#\space) '())) - '()) - (if (< tens+ones 20) - (if (> tens+ones 0) - (string->list - (list-ref format:cardinal-ones-list tens+ones)) - '()) - (append - (string->list - (list-ref format:cardinal-tens-list tens)) - (if (> ones 0) - (cons #\- - (string->list - (list-ref format:cardinal-ones-list ones))) - '()))))))) - -(define format:cardinal-thousand-block-list - '("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion" " undecillion" " duodecillion" " tredecillion" - " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" - " octodecillion" " novemdecillion" " vigintillion")) - -(define format:num->cardinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English cardinals")) - ((= n 0) "zero") - ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) - (else - (let ((power3-word-limit - (length format:cardinal-thousand-block-list))) - (let loop ((n n) - (power3 0) - (s '())) - (if (= n 0) - (list->string s) - (let ((n-before-block (quotient n 1000)) - (n-after-block (remainder n 1000))) - (loop n-before-block - (+ power3 1) - (if (> n-after-block 0) - (append - (if (> n-before-block 0) - (string->list ", ") '()) - (format:num->cardinal999 n-after-block) - (if (< power3 power3-word-limit) - (string->list - (list-ref - format:cardinal-thousand-block-list - power3)) - (append - (string->list " times ten to the ") - (string->list - (format:num->ordinal - (* power3 3))) - (string->list " power"))) - s) - s)))))))))) - -(define format:ordinal-ones-list - '(#f "first" "second" "third" "fourth" "fifth" - "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" - "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" - "eighteenth" "nineteenth")) - -(define format:ordinal-tens-list - '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" - "seventieth" "eightieth" "ninetieth")) - -(define format:num->ordinal - (lambda (n) - (cond ((not (integer? n)) - (format:error - "only integers can be converted to English ordinals")) - ((= n 0) "zeroth") - ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) - (else - (let ((hundreds (quotient n 100)) - (tens+ones (remainder n 100))) - (string-append - (if (> hundreds 0) - (string-append - (format:num->cardinal (* hundreds 100)) - (if (= tens+ones 0) "th" " ")) - "") - (if (= tens+ones 0) "" - (if (< tens+ones 20) - (list-ref format:ordinal-ones-list tens+ones) - (let ((tens (quotient tens+ones 10)) - (ones (remainder tens+ones 10))) - (if (= ones 0) - (list-ref format:ordinal-tens-list tens) - (string-append - (list-ref format:cardinal-tens-list tens) - "-" - (list-ref format:ordinal-ones-list ones)))) - )))))))) - -;; format inf and nan. - -(define (format:out-inf-nan number width digits edigits overch padch) - ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or - ;; "+nan.0", suitably justified in their field. We insist on - ;; printing this exact form so that the numbers can be read back in. - - (let* ((str (number->string number)) - (len (string-length str)) - (dot (string-index str #\.)) - (digits (+ (or digits 0) - (if edigits (+ edigits 2) 0)))) - (if (and width overch (< width len)) - (format:out-fill width (integer->char overch)) - (let* ((leftpad (if width - (max (- width (max len (+ dot 1 digits))) 0) - 0)) - (rightpad (if width - (max (- width leftpad len) 0) - 0)) - (padch (integer->char (or padch format:space-ch)))) - (format:out-fill leftpad padch) - (format:out-str str) - (format:out-fill rightpad padch))))) - -;; format fixed flonums (~F) - -(define (format:out-fixed modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) - - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (scale (format:par pars l 2 0 #f)) - (overch (format:par pars l 3 #f #f)) - (padch (format:par pars l 4 format:space-ch #f))) - - (cond - ((or (inf? number) (nan? number)) - (format:out-inf-nan number width digits #f overch padch)) - - (digits - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (format:fn-out modifier (> width (+ digits 1))))) - (format:fn-out modifier #t))) - - (else - (format:parse-float - (if (string? number) number (number->string number)) #t scale) - (format:fn-strip) - (if width - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (format:out-fill (- width numlen) (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((dot-index (- numlen - (- format:fn-len format:fn-dot)))) - (if (> dot-index width) - (if overch ; numstr too big for required width - (format:out-fill width (integer->char overch)) - (format:fn-out modifier #t)) + (format:format-work ; does the formatting work + (lambda (format-string arglist) + (letrec + ((format-string-len (string-length format-string)) + (arg-pos 0) ; argument position in arglist + (arg-len (length arglist)) ; number of arguments + (modifier #f) ; 'colon | 'at | 'colon-at | #f + (params '()) ; directive parameter list + (param-value-found #f) ; a directive + ; parameter value + ; found + (conditional-nest 0) ; conditional nesting level + (clause-pos 0) ; last cond. clause + ; beginning char pos + (clause-default #f) ; conditional default + ; clause string + (clauses '()) ; conditional clause + ; string list + (conditional-type #f) ; reflects the + ; contional modifiers + (conditional-arg #f) ; argument to apply the conditional + (iteration-nest 0) ; iteration nesting level + (iteration-pos 0) ; iteration string + ; beginning char pos + (iteration-type #f) ; reflects the + ; iteration modifiers + (max-iterations #f) ; maximum number of + ; iterations + (recursive-pos-save format:pos) + + (next-char ; gets the next char + ; from format-string + (lambda () + (let ((ch (peek-next-char))) + (set! format:pos (+ 1 format:pos)) + ch))) + + (peek-next-char + (lambda () + (if (>= format:pos format-string-len) + (format:error "illegal format string") + (string-ref format-string format:pos)))) + + (one-positive-integer? + (lambda (params) + (cond + ((null? params) #f) + ((and (integer? (car params)) + (>= (car params) 0) + (= (length params) 1)) #t) + (else + (format:error + "one positive integer parameter expected"))))) + + (next-arg + (lambda () + (if (>= arg-pos arg-len) (begin - (format:fn-round (- width dot-index)) - (format:fn-out modifier #t)))) - (format:fn-out modifier #t))) - (format:fn-out modifier #t))))))) + (set! format:arg-pos (+ arg-len 1)) + (format:error "missing argument(s)"))) + (add-arg-pos 1) + (list-ref arglist (- arg-pos 1)))) + + (prev-arg + (lambda () + (add-arg-pos -1) + (if (negative? arg-pos) + (format:error "missing backward argument(s)")) + (list-ref arglist arg-pos))) + + (rest-args + (lambda () + (let loop ((l arglist) (k arg-pos)) ; list-tail definition + (if (= k 0) l (loop (cdr l) (- k 1)))))) + + (add-arg-pos + (lambda (n) + (set! arg-pos (+ n arg-pos)) + (set! format:arg-pos arg-pos))) + + (anychar-dispatch ; dispatches the format-string + (lambda () + (if (>= format:pos format-string-len) + arg-pos ; used for ~? continuance + (let ((char (next-char))) + (cond + ((char=? char #\~) + (set! modifier #f) + (set! params '()) + (set! param-value-found #f) + (tilde-dispatch)) + (else + (if (and (zero? conditional-nest) + (zero? iteration-nest)) + (format:out-char char)) + (anychar-dispatch))))))) + + (tilde-dispatch + (lambda () + (cond + ((>= format:pos format-string-len) + (format:out-str "~") ; tilde at end of + ; string is just + ; output + arg-pos) ; used for ~? + ; continuance + ((and (or (zero? conditional-nest) + (memv (peek-next-char) ; find conditional + ; directives + (append '(#\[ #\] #\; #\: #\@ #\^) + format:parameter-characters))) + (or (zero? iteration-nest) + (memv (peek-next-char) ; find iteration + ; directives + (append '(#\{ #\} #\: #\@ #\^) + format:parameter-characters)))) + (case (char-upcase (next-char)) + + ;; format directives + + ((#\A) ; Any -- for humans + (set! format:read-proof + (memq modifier '(colon colon-at))) + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #f params) + (anychar-dispatch)) + ((#\S) ; Slashified -- for parsers + (set! format:read-proof (memq modifier + '(colon colon-at))) + (format:out-obj-padded (memq modifier '(at colon-at)) + (next-arg) #t params) + (anychar-dispatch)) + ((#\D) ; Decimal + (format:out-num-padded modifier (next-arg) params 10) + (anychar-dispatch)) + ((#\X) ; Hexadecimal + (format:out-num-padded modifier (next-arg) params 16) + (anychar-dispatch)) + ((#\O) ; Octal + (format:out-num-padded modifier (next-arg) params 8) + (anychar-dispatch)) + ((#\B) ; Binary + (format:out-num-padded modifier (next-arg) params 2) + (anychar-dispatch)) + ((#\R) + (if (null? params) + (format:out-obj-padded ; Roman, cardinal, + ; ordinal numerals + #f + ((case modifier + ((at) format:num->roman) + ((colon-at) format:num->old-roman) + ((colon) format:num->ordinal) + (else format:num->cardinal)) + (next-arg)) + #f params) + (format:out-num-padded ; any Radix + modifier (next-arg) (cdr params) (car params))) + (anychar-dispatch)) + ((#\F) ; Fixed-format floating-point + (if format:floats + (format:out-fixed modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\E) ; Exponential floating-point + (if format:floats + (format:out-expon modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\G) ; General floating-point + (if format:floats + (format:out-general modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\$) ; Dollars floating-point + (if format:floats + (format:out-dollar modifier (next-arg) params) + (format:out-str (number->string (next-arg)))) + (anychar-dispatch)) + ((#\I) ; Complex numbers + (if (not format:complex-numbers) + (format:error + "complex numbers not supported by this scheme system")) + (let ((z (next-arg))) + (if (not (complex? z)) + (format:error "argument not a complex number")) + (format:out-fixed modifier (real-part z) params) + (format:out-fixed 'at (imag-part z) params) + (format:out-char #\i)) + (anychar-dispatch)) + ((#\C) ; Character + (let ((ch (if (one-positive-integer? params) + (integer->char (car params)) + (next-arg)))) + (if (not (char? ch)) + (format:error "~~c expects a character")) + (case modifier + ((at) + (format:out-str (format:char->str ch))) + ((colon) + (let ((c (char->integer ch))) + (if (< c 0) + (set! c (+ c 256))) ; compensate + ; complement + ; impl. + (cond + ((< c #x20) ; assumes that control + ; chars are < #x20 + (format:out-char #\^) + (format:out-char + (integer->char (+ c #x40)))) + ((>= c #x7f) + (format:out-str "#\\") + (format:out-str + (if format:radix-pref + (let ((s (number->string c 8))) + (substring s 2 (string-length s))) + (number->string c 8)))) + (else + (format:out-char ch))))) + (else (format:out-char ch)))) + (anychar-dispatch)) + ((#\P) ; Plural + (if (memq modifier '(colon colon-at)) + (prev-arg)) + (let ((arg (next-arg))) + (if (not (number? arg)) + (format:error "~~p expects a number argument")) + (if (= arg 1) + (if (memq modifier '(at colon-at)) + (format:out-char #\y)) + (if (memq modifier '(at colon-at)) + (format:out-str "ies") + (format:out-char #\s)))) + (anychar-dispatch)) + ((#\~) ; Tilde + (if (one-positive-integer? params) + (format:out-fill (car params) #\~) + (format:out-char #\~)) + (anychar-dispatch)) + ((#\%) ; Newline + (if (one-positive-integer? params) + (format:out-fill (car params) #\newline) + (format:out-char #\newline)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\&) ; Fresh line + (if (one-positive-integer? params) + (begin + (if (> (car params) 0) + (format:out-fill (- (car params) + (if (> + format:output-col + 0) 0 1)) + #\newline)) + (set! format:output-col 0)) + (if (> format:output-col 0) + (format:out-char #\newline))) + (anychar-dispatch)) + ((#\_) ; Space character + (if (one-positive-integer? params) + (format:out-fill (car params) #\space) + (format:out-char #\space)) + (anychar-dispatch)) + ((#\/) ; Tabulator character + (if (one-positive-integer? params) + (format:out-fill (car params) #\tab) + (format:out-char #\tab)) + (anychar-dispatch)) + ((#\|) ; Page seperator + (if (one-positive-integer? params) + (format:out-fill (car params) #\page) + (format:out-char #\page)) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\T) ; Tabulate + (format:tabulate modifier params) + (anychar-dispatch)) + ((#\Y) ; Pretty-print + (pretty-print (next-arg) format:port) + (set! format:output-col 0) + (anychar-dispatch)) + ((#\? #\K) ; Indirection (is "~K" in T-Scheme) + (cond + ((memq modifier '(colon colon-at)) + (format:error "illegal modifier in ~~?")) + ((eq? modifier 'at) + (let* ((frmt (next-arg)) + (args (rest-args))) + (add-arg-pos (format:format-work frmt args)))) + (else + (let* ((frmt (next-arg)) + (args (next-arg))) + (format:format-work frmt args)))) + (anychar-dispatch)) + ((#\!) ; Flush output + (set! format:flush-output #t) + (anychar-dispatch)) + ((#\newline) ; Continuation lines + (if (eq? modifier 'at) + (format:out-char #\newline)) + (if (< format:pos format-string-len) + (do ((ch (peek-next-char) (peek-next-char))) + ((or (not (char-whitespace? ch)) + (= format:pos (- format-string-len 1)))) + (if (eq? modifier 'colon) + (format:out-char (next-char)) + (next-char)))) + (anychar-dispatch)) + ((#\*) ; Argument jumping + (case modifier + ((colon) ; jump backwards + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (prev-arg)) + (prev-arg))) + ((at) ; jump absolute + (set! arg-pos (if (one-positive-integer? params) + (car params) 0))) + ((colon-at) + (format:error "illegal modifier `:@' in ~~* directive")) + (else ; jump forward + (if (one-positive-integer? params) + (do ((i 0 (+ i 1))) + ((= i (car params))) + (next-arg)) + (next-arg)))) + (anychar-dispatch)) + ((#\() ; Case conversion begin + (set! format:case-conversion + (case modifier + ((at) string-capitalize-first) + ((colon) string-capitalize) + ((colon-at) string-upcase) + (else string-downcase))) + (anychar-dispatch)) + ((#\)) ; Case conversion end + (if (not format:case-conversion) + (format:error "missing ~~(")) + (set! format:case-conversion #f) + (anychar-dispatch)) + ((#\[) ; Conditional begin + (set! conditional-nest (+ conditional-nest 1)) + (cond + ((= conditional-nest 1) + (set! clause-pos format:pos) + (set! clause-default #f) + (set! clauses '()) + (set! conditional-type + (case modifier + ((at) 'if-then) + ((colon) 'if-else-then) + ((colon-at) (format:error "illegal modifier in ~~[")) + (else 'num-case))) + (set! conditional-arg + (if (one-positive-integer? params) + (car params) + (next-arg))))) + (anychar-dispatch)) + ((#\;) ; Conditional separator + (if (zero? conditional-nest) + (format:error "~~; not in ~~[~~] conditional")) + (if (not (null? params)) + (format:error "no parameter allowed in ~~;")) + (if (= conditional-nest 1) + (let ((clause-str + (cond + ((eq? modifier 'colon) + (set! clause-default #t) + (substring format-string clause-pos + (- format:pos 3))) + ((memq modifier '(at colon-at)) + (format:error "illegal modifier in ~~;")) + (else + (substring format-string clause-pos + (- format:pos 2)))))) + (set! clauses (append clauses (list clause-str))) + (set! clause-pos format:pos))) + (anychar-dispatch)) + ((#\]) ; Conditional end + (if (zero? conditional-nest) (format:error "missing ~~[")) + (set! conditional-nest (- conditional-nest 1)) + (if modifier + (format:error "no modifier allowed in ~~]")) + (if (not (null? params)) + (format:error "no parameter allowed in ~~]")) + (cond + ((zero? conditional-nest) + (let ((clause-str (substring format-string clause-pos + (- format:pos 2)))) + (if clause-default + (set! clause-default clause-str) + (set! clauses (append clauses (list clause-str))))) + (case conditional-type + ((if-then) + (if conditional-arg + (format:format-work (car clauses) + (list conditional-arg)))) + ((if-else-then) + (add-arg-pos + (format:format-work (if conditional-arg + (cadr clauses) + (car clauses)) + (rest-args)))) + ((num-case) + (if (or (not (integer? conditional-arg)) + (< conditional-arg 0)) + (format:error "argument not a positive integer")) + (if (not (and (>= conditional-arg (length clauses)) + (not clause-default))) + (add-arg-pos + (format:format-work + (if (>= conditional-arg (length clauses)) + clause-default + (list-ref clauses conditional-arg)) + (rest-args)))))))) + (anychar-dispatch)) + ((#\{) ; Iteration begin + (set! iteration-nest (+ iteration-nest 1)) + (cond + ((= iteration-nest 1) + (set! iteration-pos format:pos) + (set! iteration-type + (case modifier + ((at) 'rest-args) + ((colon) 'sublists) + ((colon-at) 'rest-sublists) + (else 'list))) + (set! max-iterations (if (one-positive-integer? params) + (car params) #f)))) + (anychar-dispatch)) + ((#\}) ; Iteration end + (if (zero? iteration-nest) (format:error "missing ~~{")) + (set! iteration-nest (- iteration-nest 1)) + (case modifier + ((colon) + (if (not max-iterations) (set! max-iterations 1))) + ((colon-at at) (format:error "illegal modifier")) + (else (if (not max-iterations) (set! max-iterations 100)))) + (if (not (null? params)) + (format:error "no parameters allowed in ~~}")) + (if (zero? iteration-nest) + (let ((iteration-str + (substring format-string iteration-pos + (- format:pos (if modifier 3 2))))) + (if (string=? iteration-str "") + (set! iteration-str (next-arg))) + (case iteration-type + ((list) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (format:error "expected a list argument")) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (>= i max-iterations)))))) + ((sublists) + (let ((args (next-arg)) + (args-len 0)) + (if (not (list? args)) + (format:error "expected a list argument")) + (set! args-len (length args)) + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (>= arg-pos max-iterations))) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (format:error + "expected a list of lists argument")) + (format:format-work iteration-str sublist))))) + ((rest-args) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos + (format:format-work + iteration-str + (list-tail + args arg-pos)))) + (i 0 (+ i 1))) + ((or (>= arg-pos args-len) + (>= i max-iterations)) + arg-pos)))) + (add-arg-pos usedup-args))) + ((rest-sublists) + (let* ((args (rest-args)) + (args-len (length args)) + (usedup-args + (do ((arg-pos 0 (+ arg-pos 1))) + ((or (>= arg-pos args-len) + (>= arg-pos max-iterations)) + arg-pos) + (let ((sublist (list-ref args arg-pos))) + (if (not (list? sublist)) + (format:error "expected list arguments")) + (format:format-work iteration-str sublist))))) + (add-arg-pos usedup-args))) + (else (format:error "internal error in ~~}"))))) + (anychar-dispatch)) + ((#\^) ; Up and out + (let* ((continue + (cond + ((not (null? params)) + (not + (case (length params) + ((1) (zero? (car params))) + ((2) (= (list-ref params 0) (list-ref params 1))) + ((3) (<= (list-ref params 0) + (list-ref params 1) + (list-ref params 2))) + (else (format:error "too much parameters"))))) + (format:case-conversion ; if conversion stop conversion + (set! format:case-conversion string-copy) #t) + ((= iteration-nest 1) #t) + ((= conditional-nest 1) #t) + ((>= arg-pos arg-len) + (set! format:pos format-string-len) #f) + (else #t)))) + (if continue + (anychar-dispatch)))) -;; format exponential flonums (~E) + ;; format directive modifiers and parameters -(define (format:out-expon modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number")) + ((#\@) ; `@' modifier + (if (memq modifier '(at colon-at)) + (format:error "double `@' modifier")) + (set! modifier (if (eq? modifier 'colon) 'colon-at 'at)) + (tilde-dispatch)) + ((#\:) ; `:' modifier + (if (memq modifier '(colon colon-at)) + (format:error "double `:' modifier")) + (set! modifier (if (eq? modifier 'at) 'colon-at 'colon)) + (tilde-dispatch)) + ((#\') ; Character parameter + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (char->integer (next-char))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\- #\+) ; num. paramtr + (if modifier (format:error "misplaced modifier")) + (let ((num-str-beg (- format:pos 1)) + (num-str-end format:pos)) + (do ((ch (peek-next-char) (peek-next-char))) + ((not (char-numeric? ch))) + (next-char) + (set! num-str-end (+ 1 num-str-end))) + (set! params + (append params + (list (string->number + (substring format-string + num-str-beg + num-str-end)))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\V) ; Variable parameter from next argum. + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (next-arg)))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\#) ; Parameter is number of remaining args + (if param-value-found (format:error "misplaced '#'")) + (if modifier (format:error "misplaced modifier")) + (set! params (append params (list (length (rest-args))))) + (set! param-value-found #t) + (tilde-dispatch)) + ((#\,) ; Parameter separators + (if modifier (format:error "misplaced modifier")) + (if (not param-value-found) + (set! params (append params '(#f)))) ; append empty paramtr + (set! param-value-found #f) + (tilde-dispatch)) + ((#\Q) ; Inquiry messages + (if (eq? modifier 'colon) + (format:out-str format:version) + (let ((nl (string #\newline))) + (format:out-str + (string-append + "SLIB Common LISP format version " format:version nl + " (C) copyright 1992-1994 by Dirk Lutzebaeck" nl + " please send bug reports to `lutzeb@cs.tu-berlin.de'" + nl)))) + (anychar-dispatch)) + (else ; Unknown tilde directive + (format:error "unknown control character `~c'" + (string-ref format-string (- format:pos 1)))))) + (else (anychar-dispatch)))))) ; in case of conditional - (let ((l (length pars))) - (let ((width (format:par pars l 0 #f "width")) - (digits (format:par pars l 1 #f "digits")) - (edigits (format:par pars l 2 #f "exponent digits")) - (scale (format:par pars l 3 1 #f)) - (overch (format:par pars l 4 #f #f)) - (padch (format:par pars l 5 format:space-ch #f)) - (expch (format:par pars l 6 #f #f))) - - (cond - ((or (inf? number) (nan? number)) - (format:out-inf-nan number width digits edigits overch padch)) + (set! format:pos 0) + (set! format:arg-pos 0) + (anychar-dispatch) ; start the formatting + (set! format:pos recursive-pos-save) + arg-pos))) ; return the position in the arg. list - (digits ; fixed precision + ;; format:obj->str returns a R4RS representation as a string of an arbitrary + ;; scheme object. + ;; First parameter is the object, second parameter is a boolean if the + ;; representation should be slashified as `write' does. + ;; It uses format:char->str which converts a character into + ;; a slashified string as `write' does and which is implementation dependent. + ;; It uses format:iobj->str to print out internal objects as + ;; quoted strings so that the output can always be processed by (read) - (let ((digits (if (> scale 0) - (if (< scale (+ digits 2)) - (+ (- digits scale) 1) - 0) - digits))) - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (if width - (if (and edigits overch (> format:en-len edigits)) - (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (and (= format:fn-dot 0) (> width (+ digits 1))) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (and overch (> numlen width)) - (format:out-fill width (integer->char overch)) - (begin - (format:fn-out modifier (> width (- numlen 1))) - (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))))) + (format:obj->str + (lambda (obj slashify) + (define (obj->str obj slashify visited) + (if (memq obj (cdr visited)) + (let ((n (- (list-index (cdr visited) (cdr obj))))) + (string-append "#" (number->string n) "#")) + (cond + ((string? obj) + (if slashify + (let ((obj-len (string-length obj))) + (string-append + "\"" + (let loop ((i 0) (j 0)) ; taken from Marc Feeley's pp.scm + (if (= j obj-len) + (string-append (substring obj i j) "\"") + (let ((c (string-ref obj j))) + (if (or (char=? c #\\) + (char=? c #\")) + (string-append (substring obj i j) "\\" + (loop j (+ j 1))) + (loop i (+ j 1)))))))) + obj)) + + ((boolean? obj) (if obj "#t" "#f")) + + ((number? obj) (number->string obj)) - (else - (format:parse-float - (if (string? number) number (number->string number)) #f scale) - (format:fn-strip) - (if width - (if (and edigits overch (> format:en-len edigits)) + ((symbol? obj) + (if format:symbol-case-conv + (format:symbol-case-conv (symbol->string obj)) + (symbol->string obj))) + + ((char? obj) + (if slashify + (format:char->str obj) + (string obj))) + + ((null? obj) "()") + + ((input-port? obj) + (format:iobj->str obj)) + + ((output-port? obj) + (format:iobj->str obj)) + + ((pair? obj) + (string-append "(" + (let loop ((obj-list obj) + (visited visited) + (offset 0) + (prefix "")) + (cond ((null? (cdr obj-list)) + (string-append + prefix + (obj->str (car obj-list) + #t + (cons (car obj-list) visited)))) + ((memq (cdr obj-list) visited) + (string-append + prefix + (obj->str (car obj-list) + #t + (cons (car obj-list) visited)) + " . #" + (number->string + (- offset + (list-index visited (cdr obj-list)))) + "#")) + ((pair? (cdr obj-list)) + (loop (cdr obj-list) + (cons (cdr obj-list) visited) + (+ 1 offset) + (string-append + prefix + (obj->str (car obj-list) + #t + (cons (car obj-list) visited)) + " "))) + (else + (string-append + prefix + (obj->str (car obj-list) + #t + (cons (car obj-list) visited)) + " . " + (obj->str (cdr obj-list) + #t + (cons (cdr obj-list) visited)))))) + ")")) + + ((vector? obj) + (string-append "#" (obj->str (vector->list obj) #t visited))) + + (else ; only objects with an #<...> + (format:iobj->str obj))))) ; representation should fall in here + (obj->str obj slashify (list obj)))) + + ;; format:iobj->str reveals the implementation dependent representation of + ;; #<...> objects with the use of display and call-with-output-string. + ;; If format:read-proof is set to #t the resulting string is additionally + ;; set into string quotes. + + (format:read-proof #f) + + (format:iobj->str + (lambda (iobj) + (if (or format:read-proof + format:iobj-case-conv) + (string-append + (if format:read-proof "\"" "") + (if format:iobj-case-conv + (format:iobj-case-conv + (call-with-output-string (lambda (p) (display iobj p)))) + (call-with-output-string (lambda (p) (display iobj p)))) + (if format:read-proof "\"" "")) + (call-with-output-string (lambda (p) (display iobj p)))))) + + + ;; format:char->str converts a character into a slashified string as + ;; done by `write'. The procedure is dependent on the integer + ;; representation of characters and assumes a character number according to + ;; the ASCII character set. + + (format:char->str + (lambda (ch) + (let ((int-rep (char->integer ch))) + (if (< int-rep 0) ; if chars are [-128...+127] + (set! int-rep (+ int-rep 256))) + (string-append + "#\\" + (cond + ((char=? ch #\newline) "newline") + ((and (>= int-rep 0) (<= int-rep 32)) + (vector-ref format:ascii-non-printable-charnames int-rep)) + ((= int-rep 127) "del") + ((>= int-rep 128) ; octal representation + (if format:radix-pref + (let ((s (number->string int-rep 8))) + (substring s 2 (string-length s))) + (number->string int-rep 8))) + (else (string ch))))))) + + (format:space-ch (char->integer #\space)) + (format:zero-ch (char->integer #\0)) + + (format:par + (lambda (pars length index default name) + (if (> length index) + (let ((par (list-ref pars index))) + (if par + (if name + (if (< par 0) + (format:error + "~s parameter must be a positive integer" name) + par) + par) + default)) + default))) + + (format:out-obj-padded + (lambda (pad-left obj slashify pars) + (if (null? pars) + (format:out-str (format:obj->str obj slashify)) + (let ((l (length pars))) + (let ((mincol (format:par pars l 0 0 "mincol")) + (colinc (format:par pars l 1 1 "colinc")) + (minpad (format:par pars l 2 0 "minpad")) + (padchar (integer->char + (format:par pars l 3 format:space-ch #f))) + (objstr (format:obj->str obj slashify))) + (if (not pad-left) + (format:out-str objstr)) + (do ((objstr-len (string-length objstr)) + (i minpad (+ i colinc))) + ((>= (+ objstr-len i) mincol) + (format:out-fill i padchar))) + (if pad-left + (format:out-str objstr))))))) + + (format:out-num-padded + (lambda (modifier number pars radix) + (if (not (integer? number)) (format:error "argument not an integer")) + (let ((numstr (number->string number radix))) + (if (and format:radix-pref (not (= radix 10))) + (set! numstr (substring numstr 2 (string-length numstr)))) + (if (and (null? pars) (not modifier)) + (format:out-str numstr) + (let ((l (length pars)) + (numstr-len (string-length numstr))) + (let ((mincol (format:par pars l 0 #f "mincol")) + (padchar (integer->char + (format:par pars l 1 format:space-ch #f))) + (commachar (integer->char + (format:par pars l 2 (char->integer #\,) #f))) + (commawidth (format:par pars l 3 3 "commawidth"))) + (if mincol + (let ((numlen numstr-len)) ; calc. the output len of number + (if (and (memq modifier '(at colon-at)) (> number 0)) + (set! numlen (+ numlen 1))) + (if (memq modifier '(colon colon-at)) + (set! numlen (+ (quotient (- numstr-len + (if (< number 0) 2 1)) + commawidth) + numlen))) + (if (> mincol numlen) + (format:out-fill (- mincol numlen) padchar)))) + (if (and (memq modifier '(at colon-at)) + (> number 0)) + (format:out-char #\+)) + (if (memq modifier '(colon colon-at)) ; insert comma character + (let ((start (remainder numstr-len commawidth)) + (ns (if (< number 0) 1 0))) + (format:out-substr numstr 0 start) + (do ((i start (+ i commawidth))) + ((>= i numstr-len)) + (if (> i ns) + (format:out-char commachar)) + (format:out-substr numstr i (+ i commawidth)))) + (format:out-str numstr)))))))) + + (format:tabulate + (lambda (modifier pars) + (let ((l (length pars))) + (let ((colnum (format:par pars l 0 1 "colnum")) + (colinc (format:par pars l 1 1 "colinc")) + (padch (integer->char (format:par pars l 2 format:space-ch #f)))) + (case modifier + ((colon colon-at) + (format:error "unsupported modifier for ~~t")) + ((at) ; relative tabulation + (format:out-fill + (if (= colinc 0) + colnum ; colnum = colrel + (do ((c 0 (+ c colinc)) + (col (+ format:output-col colnum))) + ((>= c col) + (- c format:output-col)))) + padch)) + (else ; absolute tabulation + (format:out-fill + (cond + ((< format:output-col colnum) + (- colnum format:output-col)) + ((= colinc 0) + 0) + (else + (do ((c colnum (+ c colinc))) + ((>= c format:output-col) + (- c format:output-col))))) + padch))))))) + + + ;; roman numerals (from dorai@cs.rice.edu). + + (format:roman-alist + '((1000 #\M) (500 #\D) (100 #\C) (50 #\L) + (10 #\X) (5 #\V) (1 #\I))) + + (format:roman-boundary-values + '(100 100 10 10 1 1 #f)) + + (format:num->old-roman + (lambda (n) + (if (and (integer? n) (>= n 1)) + (let loop ((n n) + (romans format:roman-alist) + (s '())) + (if (null? romans) (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans))) + (do ((q (quotient n roman-val) (- q 1)) + (s s (cons roman-dgt s))) + ((= q 0) + (loop (remainder n roman-val) + (cdr romans) s)))))) + (format:error "only positive integers can be romanized")))) + + (format:num->roman + (lambda (n) + (if (and (integer? n) (> n 0)) + (let loop ((n n) + (romans format:roman-alist) + (boundaries format:roman-boundary-values) + (s '())) + (if (null? romans) + (list->string (reverse s)) + (let ((roman-val (caar romans)) + (roman-dgt (cadar romans)) + (bdry (car boundaries))) + (let loop2 ((q (quotient n roman-val)) + (r (remainder n roman-val)) + (s s)) + (if (= q 0) + (if (and bdry (>= r (- roman-val bdry))) + (loop (remainder r bdry) (cdr romans) + (cdr boundaries) + (cons roman-dgt + (append + (cdr (assv bdry romans)) + s))) + (loop r (cdr romans) (cdr boundaries) s)) + (loop2 (- q 1) r (cons roman-dgt s))))))) + (format:error "only positive integers can be romanized")))) + + ;; cardinals & ordinals (from dorai@cs.rice.edu) + + (format:cardinal-ones-list + '(#f "one" "two" "three" "four" "five" + "six" "seven" "eight" "nine" "ten" "eleven" "twelve" "thirteen" + "fourteen" "fifteen" "sixteen" "seventeen" "eighteen" + "nineteen")) + + (format:cardinal-tens-list + '(#f #f "twenty" "thirty" "forty" "fifty" "sixty" "seventy" "eighty" + "ninety")) + + (format:num->cardinal999 + (lambda (n) + ;this procedure is inspired by the Bruno Haible's CLisp + ;function format-small-cardinal, which converts numbers + ;in the range 1 to 999, and is used for converting each + ;thousand-block in a larger number + (let* ((hundreds (quotient n 100)) + (tens+ones (remainder n 100)) + (tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (append + (if (> hundreds 0) + (append + (string->list + (list-ref format:cardinal-ones-list hundreds)) + (string->list" hundred") + (if (> tens+ones 0) '(#\space) '())) + '()) + (if (< tens+ones 20) + (if (> tens+ones 0) + (string->list + (list-ref format:cardinal-ones-list tens+ones)) + '()) + (append + (string->list + (list-ref format:cardinal-tens-list tens)) + (if (> ones 0) + (cons #\- + (string->list + (list-ref format:cardinal-ones-list ones))) + '()))))))) + + (format:cardinal-thousand-block-list + '("" " thousand" " million" " billion" " trillion" " quadrillion" + " quintillion" " sextillion" " septillion" " octillion" " nonillion" + " decillion" " undecillion" " duodecillion" " tredecillion" + " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" + " octodecillion" " novemdecillion" " vigintillion")) + + (format:num->cardinal + (lambda (n) + (cond ((not (integer? n)) + (format:error + "only integers can be converted to English cardinals")) + ((= n 0) "zero") + ((< n 0) (string-append "minus " (format:num->cardinal (- n)))) + (else + (let ((power3-word-limit + (length format:cardinal-thousand-block-list))) + (let loop ((n n) + (power3 0) + (s '())) + (if (= n 0) + (list->string s) + (let ((n-before-block (quotient n 1000)) + (n-after-block (remainder n 1000))) + (loop n-before-block + (+ power3 1) + (if (> n-after-block 0) + (append + (if (> n-before-block 0) + (string->list ", ") '()) + (format:num->cardinal999 n-after-block) + (if (< power3 power3-word-limit) + (string->list + (list-ref + format:cardinal-thousand-block-list + power3)) + (append + (string->list " times ten to the ") + (string->list + (format:num->ordinal + (* power3 3))) + (string->list " power"))) + s) + s)))))))))) + + (format:ordinal-ones-list + '(#f "first" "second" "third" "fourth" "fifth" + "sixth" "seventh" "eighth" "ninth" "tenth" "eleventh" "twelfth" + "thirteenth" "fourteenth" "fifteenth" "sixteenth" "seventeenth" + "eighteenth" "nineteenth")) + + (format:ordinal-tens-list + '(#f #f "twentieth" "thirtieth" "fortieth" "fiftieth" "sixtieth" + "seventieth" "eightieth" "ninetieth")) + + (format:num->ordinal + (lambda (n) + (cond ((not (integer? n)) + (format:error + "only integers can be converted to English ordinals")) + ((= n 0) "zeroth") + ((< n 0) (string-append "minus " (format:num->ordinal (- n)))) + (else + (let ((hundreds (quotient n 100)) + (tens+ones (remainder n 100))) + (string-append + (if (> hundreds 0) + (string-append + (format:num->cardinal (* hundreds 100)) + (if (= tens+ones 0) "th" " ")) + "") + (if (= tens+ones 0) "" + (if (< tens+ones 20) + (list-ref format:ordinal-ones-list tens+ones) + (let ((tens (quotient tens+ones 10)) + (ones (remainder tens+ones 10))) + (if (= ones 0) + (list-ref format:ordinal-tens-list tens) + (string-append + (list-ref format:cardinal-tens-list tens) + "-" + (list-ref format:ordinal-ones-list ones)))) + )))))))) + + ;; format inf and nan. + + (format:out-inf-nan + (lambda (number width digits edigits overch padch) + ;; inf and nan are always printed exactly as "+inf.0", "-inf.0" or + ;; "+nan.0", suitably justified in their field. We insist on + ;; printing this exact form so that the numbers can be read back in. + + (let* ((str (number->string number)) + (len (string-length str)) + (dot (string-index str #\.)) + (digits (+ (or digits 0) + (if edigits (+ edigits 2) 0)))) + (if (and width overch (< width len)) (format:out-fill width (integer->char overch)) - (let ((numlen (+ format:fn-len 3))) ; .E+ - (if (or (not format:fn-pos?) (eq? modifier 'at)) - (set! numlen (+ numlen 1))) - (if (= format:fn-dot 0) - (set! numlen (+ numlen 1))) - (set! numlen - (+ numlen - (if (and edigits (>= edigits format:en-len)) - edigits - format:en-len))) - (if (< numlen width) - (format:out-fill (- width numlen) - (integer->char padch))) - (if (> numlen width) ; adjust precision if possible - (let ((f (- format:fn-len format:fn-dot))) ; fract len - (if (> (- numlen f) width) - (if overch ; numstr too big for required width - (format:out-fill width - (integer->char overch)) + (let* ((leftpad (if width + (max (- width (max len (+ dot 1 digits))) 0) + 0)) + (rightpad (if width + (max (- width leftpad len) 0) + 0)) + (padch (integer->char (or padch format:space-ch)))) + (format:out-fill leftpad padch) + (format:out-str str) + (format:out-fill rightpad padch)))))) + + ;; format fixed flonums (~F) + + (format:out-fixed + (lambda (modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (scale (format:par pars l 2 0 #f)) + (overch (format:par pars l 3 #f #f)) + (padch (format:par pars l 4 format:space-ch #f))) + + (cond + ((or (inf? number) (nan? number)) + (format:out-inf-nan number width digits #f overch padch)) + + (digits + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (format:fn-out modifier (> width (+ digits 1))))) + (format:fn-out modifier #t))) + + (else + (format:parse-float + (if (string? number) number (number->string number)) #t scale) + (format:fn-strip) + (if width + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (format:out-fill (- width numlen) (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((dot-index (- numlen + (- format:fn-len format:fn-dot)))) + (if (> dot-index width) + (if overch ; numstr too big for required width + (format:out-fill width (integer->char overch)) + (format:fn-out modifier #t)) (begin - (format:fn-out modifier #t) - (format:en-out edigits expch))) - (begin - (format:fn-round (+ (- f numlen) width)) - (format:fn-out modifier #t) - (format:en-out edigits expch)))) + (format:fn-round (- width dot-index)) + (format:fn-out modifier #t)))) + (format:fn-out modifier #t))) + (format:fn-out modifier #t)))))))) + + ;; format exponential flonums (~E) + + (format:out-expon + (lambda (modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number")) + + (let ((l (length pars))) + (let ((width (format:par pars l 0 #f "width")) + (digits (format:par pars l 1 #f "digits")) + (edigits (format:par pars l 2 #f "exponent digits")) + (scale (format:par pars l 3 1 #f)) + (overch (format:par pars l 4 #f #f)) + (padch (format:par pars l 5 format:space-ch #f)) + (expch (format:par pars l 6 #f #f))) + + (cond + ((or (inf? number) (nan? number)) + (format:out-inf-nan number width digits edigits overch padch)) + + (digits ; fixed precision + + (let ((digits (if (> scale 0) + (if (< scale (+ digits 2)) + (+ (- digits scale) 1) + 0) + digits))) + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (and (= format:fn-dot 0) (> width (+ digits 1))) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (and overch (> numlen width)) + (format:out-fill width (integer->char overch)) + (begin + (format:fn-out modifier (> width (- numlen 1))) + (format:en-out edigits expch))))) (begin (format:fn-out modifier #t) (format:en-out edigits expch))))) - (begin - (format:fn-out modifier #t) - (format:en-out edigits expch)))))))) - -;; format general flonums (~G) -(define (format:out-general modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) + (else + (format:parse-float + (if (string? number) number (number->string number)) #f scale) + (format:fn-strip) + (if width + (if (and edigits overch (> format:en-len edigits)) + (format:out-fill width (integer->char overch)) + (let ((numlen (+ format:fn-len 3))) ; .E+ + (if (or (not format:fn-pos?) (eq? modifier 'at)) + (set! numlen (+ numlen 1))) + (if (= format:fn-dot 0) + (set! numlen (+ numlen 1))) + (set! numlen + (+ numlen + (if (and edigits (>= edigits format:en-len)) + edigits + format:en-len))) + (if (< numlen width) + (format:out-fill (- width numlen) + (integer->char padch))) + (if (> numlen width) ; adjust precision if possible + (let ((f (- format:fn-len format:fn-dot))) ; fract len + (if (> (- numlen f) width) + (if overch ; numstr too big for required width + (format:out-fill width + (integer->char overch)) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))) + (begin + (format:fn-round (+ (- f numlen) width)) + (format:fn-out modifier #t) + (format:en-out edigits expch)))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))))) + (begin + (format:fn-out modifier #t) + (format:en-out edigits expch))))))))) + + ;; format general flonums (~G) - (let ((l (length pars))) - (let ((width (if (> l 0) (list-ref pars 0) #f)) - (digits (if (> l 1) (list-ref pars 1) #f)) - (edigits (if (> l 2) (list-ref pars 2) #f)) - (overch (if (> l 4) (list-ref pars 4) #f)) - (padch (if (> l 5) (list-ref pars 5) #f))) - (cond - ((or (inf? number) (nan? number)) - ;; FIXME: this isn't right. - (format:out-inf-nan number width digits edigits overch padch)) - (else - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (format:fn-strip) - (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm - (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 - (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? - (- (format:fn-zlead)) - format:fn-dot)) - (d (if digits - digits - (max format:fn-len (min n 7)))) ; q = format:fn-len - (dd (- d n))) - (if (<= 0 dd d) - (begin - (format:out-fixed modifier number (list ww dd #f overch padch)) - (format:out-fill ee #\space)) ;~@T not implemented yet - (format:out-expon modifier number pars)))))))) + (format:out-general + (lambda (modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) -;; format dollar flonums (~$) + (let ((l (length pars))) + (let ((width (if (> l 0) (list-ref pars 0) #f)) + (digits (if (> l 1) (list-ref pars 1) #f)) + (edigits (if (> l 2) (list-ref pars 2) #f)) + (overch (if (> l 4) (list-ref pars 4) #f)) + (padch (if (> l 5) (list-ref pars 5) #f))) + (cond + ((or (inf? number) (nan? number)) + ;; FIXME: this isn't right. + (format:out-inf-nan number width digits edigits overch padch)) + (else + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (format:fn-strip) + (let* ((ee (if edigits (+ edigits 2) 4)) ; for the following algorithm + (ww (if width (- width ee) #f)) ; see Steele's CL book p.395 + (n (if (= format:fn-dot 0) ; number less than (abs 1.0) ? + (- (format:fn-zlead)) + format:fn-dot)) + (d (if digits + digits + (max format:fn-len (min n 7)))) ; q = format:fn-len + (dd (- d n))) + (if (<= 0 dd d) + (begin + (format:out-fixed modifier number (list ww dd #f overch padch)) + (format:out-fill ee #\space)) ;~@T not implemented yet + (format:out-expon modifier number pars))))))))) -(define (format:out-dollar modifier number pars) - (if (not (or (number? number) (string? number))) - (format:error "argument is not a number or a number string")) + ;; format dollar flonums (~$) - (let ((l (length pars))) - (let ((digits (format:par pars l 0 2 "digits")) - (mindig (format:par pars l 1 1 "mindig")) - (width (format:par pars l 2 0 "width")) - (padch (format:par pars l 3 format:space-ch #f))) + (format:out-dollar + (lambda (modifier number pars) + (if (not (or (number? number) (string? number))) + (format:error "argument is not a number or a number string")) - (format:parse-float - (if (string? number) number (number->string number)) #t 0) - (if (<= (- format:fn-len format:fn-dot) digits) - (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) - (format:fn-round digits)) - (let ((numlen (+ format:fn-len 1))) - (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) - (set! numlen (+ numlen 1))) - (if (and mindig (> mindig format:fn-dot)) - (set! numlen (+ numlen (- mindig format:fn-dot)))) - (if (and (= format:fn-dot 0) (not mindig)) - (set! numlen (+ numlen 1))) - (if (< numlen width) - (case modifier - ((colon) - (if (not format:fn-pos?) - (format:out-char #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - ((at) - (format:out-fill (- width numlen) (integer->char padch)) - (format:out-char (if format:fn-pos? #\+ #\-))) - ((colon-at) - (format:out-char (if format:fn-pos? #\+ #\-)) - (format:out-fill (- width numlen) (integer->char padch))) - (else - (format:out-fill (- width numlen) (integer->char padch)) - (if (not format:fn-pos?) - (format:out-char #\-)))) - (if format:fn-pos? - (if (memq modifier '(at colon-at)) (format:out-char #\+)) - (format:out-char #\-)))) - (if (and mindig (> mindig format:fn-dot)) - (format:out-fill (- mindig format:fn-dot) #\0)) - (if (and (= format:fn-dot 0) (not mindig)) - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)))) + (let ((l (length pars))) + (let ((digits (format:par pars l 0 2 "digits")) + (mindig (format:par pars l 1 1 "mindig")) + (width (format:par pars l 2 0 "width")) + (padch (format:par pars l 3 format:space-ch #f))) -; the flonum buffers + (format:parse-float + (if (string? number) number (number->string number)) #t 0) + (if (<= (- format:fn-len format:fn-dot) digits) + (format:fn-zfill #f (- digits (- format:fn-len format:fn-dot))) + (format:fn-round digits)) + (let ((numlen (+ format:fn-len 1))) + (if (or (not format:fn-pos?) (memq modifier '(at colon-at))) + (set! numlen (+ numlen 1))) + (if (and mindig (> mindig format:fn-dot)) + (set! numlen (+ numlen (- mindig format:fn-dot)))) + (if (and (= format:fn-dot 0) (not mindig)) + (set! numlen (+ numlen 1))) + (if (< numlen width) + (case modifier + ((colon) + (if (not format:fn-pos?) + (format:out-char #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + ((at) + (format:out-fill (- width numlen) (integer->char padch)) + (format:out-char (if format:fn-pos? #\+ #\-))) + ((colon-at) + (format:out-char (if format:fn-pos? #\+ #\-)) + (format:out-fill (- width numlen) (integer->char padch))) + (else + (format:out-fill (- width numlen) (integer->char padch)) + (if (not format:fn-pos?) + (format:out-char #\-)))) + (if format:fn-pos? + (if (memq modifier '(at colon-at)) (format:out-char #\+)) + (format:out-char #\-)))) + (if (and mindig (> mindig format:fn-dot)) + (format:out-fill (- mindig format:fn-dot) #\0)) + (if (and (= format:fn-dot 0) (not mindig)) + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len))))) -(define format:fn-max 400) ; max. number of number digits -(define format:fn-str (make-string format:fn-max)) ; number buffer -(define format:fn-len 0) ; digit length of number -(define format:fn-dot #f) ; dot position of number -(define format:fn-pos? #t) ; number positive? -(define format:en-max 10) ; max. number of exponent digits -(define format:en-str (make-string format:en-max)) ; exponent buffer -(define format:en-len 0) ; digit length of exponent -(define format:en-pos? #t) ; exponent positive? + ; the flonum buffers -(define (format:parse-float num-str fixed? scale) - (set! format:fn-pos? #t) - (set! format:fn-len 0) - (set! format:fn-dot #f) - (set! format:en-pos? #t) - (set! format:en-len 0) - (do ((i 0 (+ i 1)) - (left-zeros 0) - (mantissa? #t) - (all-zeros? #t) - (num-len (string-length num-str)) - (c #f)) ; current exam. character in num-str - ((= i num-len) - (if (not format:fn-dot) - (set! format:fn-dot format:fn-len)) + (format:fn-max 400) ; max. number of number digits + (format:fn-str #f) ; number buffer + (format:fn-len 0) ; digit length of number + (format:fn-dot #f) ; dot position of number + (format:fn-pos? #t) ; number positive? + (format:en-max 10) ; max. number of exponent digits + (format:en-str #f) ; exponent buffer + (format:en-len 0) ; digit length of exponent + (format:en-pos? #t) ; exponent positive? - (if all-zeros? - (begin - (set! left-zeros 0) - (set! format:fn-dot 0) - (set! format:fn-len 1))) + (format:parse-float + (lambda (num-str fixed? scale) + (set! format:fn-pos? #t) + (set! format:fn-len 0) + (set! format:fn-dot #f) + (set! format:en-pos? #t) + (set! format:en-len 0) + (do ((i 0 (+ i 1)) + (left-zeros 0) + (mantissa? #t) + (all-zeros? #t) + (num-len (string-length num-str)) + (c #f)) ; current exam. character in num-str + ((= i num-len) + (if (not format:fn-dot) + (set! format:fn-dot format:fn-len)) - ;; now format the parsed values according to format's need + (if all-zeros? + (begin + (set! left-zeros 0) + (set! format:fn-dot 0) + (set! format:fn-len 1))) - (if fixed? + ;; now format the parsed values according to format's need - (begin ; fixed format m.nnn or .nnn - (if (and (> left-zeros 0) (> format:fn-dot 0)) - (if (> format:fn-dot left-zeros) - (begin ; norm 0{0}nn.mm to nn.mm - (format:fn-shiftleft left-zeros) - (set! left-zeros 0) - (set! format:fn-dot (- format:fn-dot left-zeros))) - (begin ; normalize 0{0}.nnn to .nnn - (format:fn-shiftleft format:fn-dot) - (set! left-zeros (- left-zeros format:fn-dot)) - (set! format:fn-dot 0)))) - (if (or (not (= scale 0)) (> format:en-len 0)) - (let ((shift (+ scale (format:en-int)))) - (cond - (all-zeros? #t) - ((> (+ format:fn-dot shift) format:fn-len) - (format:fn-zfill - #f (- shift (- format:fn-len format:fn-dot))) + (if fixed? + + (begin ; fixed format m.nnn or .nnn + (if (and (> left-zeros 0) (> format:fn-dot 0)) + (if (> format:fn-dot left-zeros) + (begin ; norm 0{0}nn.mm to nn.mm + (format:fn-shiftleft left-zeros) + (set! left-zeros 0) + (set! format:fn-dot (- format:fn-dot left-zeros))) + (begin ; normalize 0{0}.nnn to .nnn + (format:fn-shiftleft format:fn-dot) + (set! left-zeros (- left-zeros format:fn-dot)) + (set! format:fn-dot 0)))) + (if (or (not (= scale 0)) (> format:en-len 0)) + (let ((shift (+ scale (format:en-int)))) + (cond + (all-zeros? #t) + ((> (+ format:fn-dot shift) format:fn-len) + (format:fn-zfill + #f (- shift (- format:fn-len format:fn-dot))) + (set! format:fn-dot format:fn-len)) + ((< (+ format:fn-dot shift) 0) + (format:fn-zfill #t (- (- shift) format:fn-dot)) + (set! format:fn-dot 0)) + (else + (if (> left-zeros 0) + (if (<= left-zeros shift) ; shift always > 0 here + (format:fn-shiftleft shift) ; shift out 0s + (begin + (format:fn-shiftleft left-zeros) + (set! format:fn-dot (- shift left-zeros)))) + (set! format:fn-dot (+ format:fn-dot shift)))))))) + + (let ((negexp ; expon format m.nnnEee + (if (> left-zeros 0) + (- left-zeros format:fn-dot -1) + (if (= format:fn-dot 0) 1 0)))) + (if (> left-zeros 0) + (begin ; normalize 0{0}.nnn to n.nn + (format:fn-shiftleft left-zeros) + (set! format:fn-dot 1)) + (if (= format:fn-dot 0) + (set! format:fn-dot 1))) + (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) + negexp)) + (cond + (all-zeros? + (format:en-set 0) + (set! format:fn-dot 1)) + ((< scale 0) ; leading zero + (format:fn-zfill #t (- scale)) + (set! format:fn-dot 0)) + ((> scale format:fn-dot) + (format:fn-zfill #f (- scale format:fn-dot)) + (set! format:fn-dot scale)) + (else + (set! format:fn-dot scale))))) + #t) + + ;; do body + (set! c (string-ref num-str i)) ; parse the output of number->string + (cond ; which can be any valid number + ((char-numeric? c) ; representation of R4RS except + (if mantissa? ; complex numbers + (begin + (if (char=? c #\0) + (if all-zeros? + (set! left-zeros (+ left-zeros 1))) + (begin + (set! all-zeros? #f))) + (string-set! format:fn-str format:fn-len c) + (set! format:fn-len (+ format:fn-len 1))) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1))))) + ((or (char=? c #\-) (char=? c #\+)) + (if mantissa? + (set! format:fn-pos? (char=? c #\+)) + (set! format:en-pos? (char=? c #\+)))) + ((char=? c #\.) (set! format:fn-dot format:fn-len)) - ((< (+ format:fn-dot shift) 0) - (format:fn-zfill #t (- (- shift) format:fn-dot)) - (set! format:fn-dot 0)) + ((char=? c #\e) + (set! mantissa? #f)) + ((char=? c #\E) + (set! mantissa? #f)) + ((char-whitespace? c) #t) + ((char=? c #\d) #t) ; decimal radix prefix + ((char=? c #\#) #t) (else - (if (> left-zeros 0) - (if (<= left-zeros shift) ; shift always > 0 here - (format:fn-shiftleft shift) ; shift out 0s - (begin - (format:fn-shiftleft left-zeros) - (set! format:fn-dot (- shift left-zeros)))) - (set! format:fn-dot (+ format:fn-dot shift)))))))) + (format:error "illegal character `~c' in number->string" c)))))) - (let ((negexp ; expon format m.nnnEee - (if (> left-zeros 0) - (- left-zeros format:fn-dot -1) - (if (= format:fn-dot 0) 1 0)))) - (if (> left-zeros 0) - (begin ; normalize 0{0}.nnn to n.nn - (format:fn-shiftleft left-zeros) - (set! format:fn-dot 1)) - (if (= format:fn-dot 0) - (set! format:fn-dot 1))) - (format:en-set (- (+ (- format:fn-dot scale) (format:en-int)) - negexp)) - (cond - (all-zeros? - (format:en-set 0) - (set! format:fn-dot 1)) - ((< scale 0) ; leading zero - (format:fn-zfill #t (- scale)) - (set! format:fn-dot 0)) - ((> scale format:fn-dot) - (format:fn-zfill #f (- scale format:fn-dot)) - (set! format:fn-dot scale)) - (else - (set! format:fn-dot scale))))) - #t) + (format:en-int + (lambda () ; convert exponent string to integer + (if (= format:en-len 0) + 0 + (do ((i 0 (+ i 1)) + (n 0)) + ((= i format:en-len) + (if format:en-pos? + n + (- n))) + (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) + format:zero-ch))))))) - ;; do body - (set! c (string-ref num-str i)) ; parse the output of number->string - (cond ; which can be any valid number - ((char-numeric? c) ; representation of R4RS except - (if mantissa? ; complex numbers - (begin - (if (char=? c #\0) - (if all-zeros? - (set! left-zeros (+ left-zeros 1))) - (begin - (set! all-zeros? #f))) - (string-set! format:fn-str format:fn-len c) - (set! format:fn-len (+ format:fn-len 1))) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))) - ((or (char=? c #\-) (char=? c #\+)) - (if mantissa? - (set! format:fn-pos? (char=? c #\+)) - (set! format:en-pos? (char=? c #\+)))) - ((char=? c #\.) - (set! format:fn-dot format:fn-len)) - ((char=? c #\e) - (set! mantissa? #f)) - ((char=? c #\E) - (set! mantissa? #f)) - ((char-whitespace? c) #t) - ((char=? c #\d) #t) ; decimal radix prefix - ((char=? c #\#) #t) - (else - (format:error "illegal character `~c' in number->string" c))))) + (format:en-set ; set exponent string number + (lambda (en) + (set! format:en-len 0) + (set! format:en-pos? (>= en 0)) + (let ((en-str (number->string en))) + (do ((i 0 (+ i 1)) + (en-len (string-length en-str)) + (c #f)) + ((= i en-len)) + (set! c (string-ref en-str i)) + (if (char-numeric? c) + (begin + (string-set! format:en-str format:en-len c) + (set! format:en-len (+ format:en-len 1)))))))) -(define (format:en-int) ; convert exponent string to integer - (if (= format:en-len 0) - 0 - (do ((i 0 (+ i 1)) - (n 0)) - ((= i format:en-len) - (if format:en-pos? - n - (- n))) - (set! n (+ (* n 10) (- (char->integer (string-ref format:en-str i)) - format:zero-ch)))))) + (format:fn-zfill ; fill current number string with 0s + (lambda (left? n) + (if (> (+ n format:fn-len) format:fn-max) ; from the left or right + (format:error "number is too long to format (enlarge format:fn-max)")) + (set! format:fn-len (+ format:fn-len n)) + (if left? + (do ((i format:fn-len (- i 1))) ; fill n 0s to left + ((< i 0)) + (string-set! format:fn-str i + (if (< i n) + #\0 + (string-ref format:fn-str (- i n))))) + (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right + ((= i format:fn-len)) + (string-set! format:fn-str i #\0))))) -(define (format:en-set en) ; set exponent string number - (set! format:en-len 0) - (set! format:en-pos? (>= en 0)) - (let ((en-str (number->string en))) - (do ((i 0 (+ i 1)) - (en-len (string-length en-str)) - (c #f)) - ((= i en-len)) - (set! c (string-ref en-str i)) - (if (char-numeric? c) - (begin - (string-set! format:en-str format:en-len c) - (set! format:en-len (+ format:en-len 1))))))) + (format:fn-shiftleft ; shift left current number n positions + (lambda (n) + (if (> n format:fn-len) + (format:error "internal error in format:fn-shiftleft (~d,~d)" + n format:fn-len)) + (do ((i n (+ i 1))) + ((= i format:fn-len) + (set! format:fn-len (- format:fn-len n))) + (string-set! format:fn-str (- i n) (string-ref format:fn-str i))))) -(define (format:fn-zfill left? n) ; fill current number string with 0s - (if (> (+ n format:fn-len) format:fn-max) ; from the left or right - (format:error "number is too long to format (enlarge format:fn-max)")) - (set! format:fn-len (+ format:fn-len n)) - (if left? - (do ((i format:fn-len (- i 1))) ; fill n 0s to left - ((< i 0)) - (string-set! format:fn-str i - (if (< i n) - #\0 - (string-ref format:fn-str (- i n))))) - (do ((i (- format:fn-len n) (+ i 1))) ; fill n 0s to the right - ((= i format:fn-len)) - (string-set! format:fn-str i #\0)))) + (format:fn-round ; round format:fn-str + (lambda (digits) + (set! digits (+ digits format:fn-dot)) + (do ((i digits (- i 1)) ; "099",2 -> "10" + (c 5)) ; "023",2 -> "02" + ((or (= c 0) (< i 0)) ; "999",2 -> "100" + (if (= c 1) ; "005",2 -> "01" + (begin ; carry overflow + (set! format:fn-len digits) + (format:fn-zfill #t 1) ; add a 1 before fn-str + (string-set! format:fn-str 0 #\1) + (set! format:fn-dot (+ format:fn-dot 1))) + (set! format:fn-len digits))) + (set! c (+ (- (char->integer (string-ref format:fn-str i)) + format:zero-ch) c)) + (string-set! format:fn-str i (integer->char + (if (< c 10) + (+ c format:zero-ch) + (+ (- c 10) format:zero-ch)))) + (set! c (if (< c 10) 0 1))))) -(define (format:fn-shiftleft n) ; shift left current number n positions - (if (> n format:fn-len) - (format:error "internal error in format:fn-shiftleft (~d,~d)" - n format:fn-len)) - (do ((i n (+ i 1))) - ((= i format:fn-len) - (set! format:fn-len (- format:fn-len n))) - (string-set! format:fn-str (- i n) (string-ref format:fn-str i)))) + (format:fn-out + (lambda (modifier add-leading-zero?) + (if format:fn-pos? + (if (eq? modifier 'at) + (format:out-char #\+)) + (format:out-char #\-)) + (if (= format:fn-dot 0) + (if add-leading-zero? + (format:out-char #\0)) + (format:out-substr format:fn-str 0 format:fn-dot)) + (format:out-char #\.) + (format:out-substr format:fn-str format:fn-dot format:fn-len))) -(define (format:fn-round digits) ; round format:fn-str - (set! digits (+ digits format:fn-dot)) - (do ((i digits (- i 1)) ; "099",2 -> "10" - (c 5)) ; "023",2 -> "02" - ((or (= c 0) (< i 0)) ; "999",2 -> "100" - (if (= c 1) ; "005",2 -> "01" - (begin ; carry overflow - (set! format:fn-len digits) - (format:fn-zfill #t 1) ; add a 1 before fn-str - (string-set! format:fn-str 0 #\1) - (set! format:fn-dot (+ format:fn-dot 1))) - (set! format:fn-len digits))) - (set! c (+ (- (char->integer (string-ref format:fn-str i)) - format:zero-ch) c)) - (string-set! format:fn-str i (integer->char - (if (< c 10) - (+ c format:zero-ch) - (+ (- c 10) format:zero-ch)))) - (set! c (if (< c 10) 0 1)))) + (format:en-out + (lambda (edigits expch) + (format:out-char (if expch (integer->char expch) format:expch)) + (format:out-char (if format:en-pos? #\+ #\-)) + (if edigits + (if (< format:en-len edigits) + (format:out-fill (- edigits format:en-len) #\0))) + (format:out-substr format:en-str 0 format:en-len))) -(define (format:fn-out modifier add-leading-zero?) - (if format:fn-pos? - (if (eq? modifier 'at) - (format:out-char #\+)) - (format:out-char #\-)) - (if (= format:fn-dot 0) - (if add-leading-zero? - (format:out-char #\0)) - (format:out-substr format:fn-str 0 format:fn-dot)) - (format:out-char #\.) - (format:out-substr format:fn-str format:fn-dot format:fn-len)) + (format:fn-strip ; strip trailing zeros but one + (lambda () + (string-set! format:fn-str format:fn-len #\0) + (do ((i format:fn-len (- i 1))) + ((or (not (char=? (string-ref format:fn-str i) #\0)) + (<= i format:fn-dot)) + (set! format:fn-len (+ i 1)))))) -(define (format:en-out edigits expch) - (format:out-char (if expch (integer->char expch) format:expch)) - (format:out-char (if format:en-pos? #\+ #\-)) - (if edigits - (if (< format:en-len edigits) - (format:out-fill (- edigits format:en-len) #\0))) - (format:out-substr format:en-str 0 format:en-len)) - -(define (format:fn-strip) ; strip trailing zeros but one - (string-set! format:fn-str format:fn-len #\0) - (do ((i format:fn-len (- i 1))) - ((or (not (char=? (string-ref format:fn-str i) #\0)) - (<= i format:fn-dot)) - (set! format:fn-len (+ i 1))))) - -(define (format:fn-zlead) ; count leading zeros - (do ((i 0 (+ i 1))) - ((or (= i format:fn-len) - (not (char=? (string-ref format:fn-str i) #\0))) - (if (= i format:fn-len) ; found a real zero - 0 - i)))) + (format:fn-zlead ; count leading zeros + (lambda () + (do ((i 0 (+ i 1))) + ((or (= i format:fn-len) + (not (char=? (string-ref format:fn-str i) #\0))) + (if (= i format:fn-len) ; found a real zero + 0 + i))))) ;;; some global functions not found in SLIB -(define (string-capitalize-first str) ; "hello" -> "Hello" - (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" - (non-first-alpha #f) ; "*hello" -> "*Hello" - (str-len (string-length str))) ; "hello you" -> "Hello you" - (do ((i 0 (+ i 1))) - ((= i str-len) cap-str) - (let ((c (string-ref str i))) - (if (char-alphabetic? c) - (if non-first-alpha - (string-set! cap-str i (char-downcase c)) - (begin - (set! non-first-alpha #t) - (string-set! cap-str i (char-upcase c))))))))) + (string-capitalize-first ; "hello" -> "Hello" + (lambda (str) + (let ((cap-str (string-copy str)) ; "hELLO" -> "Hello" + (non-first-alpha #f) ; "*hello" -> "*Hello" + (str-len (string-length str))) ; "hello you" -> "Hello you" + (do ((i 0 (+ i 1))) + ((= i str-len) cap-str) + (let ((c (string-ref str i))) + (if (char-alphabetic? c) + (if non-first-alpha + (string-set! cap-str i (char-downcase c)) + (begin + (set! non-first-alpha #t) + (string-set! cap-str i (char-upcase c)))))))))) -;; Aborts the program when a formatting error occures. This is a null -;; argument closure to jump to the interpreters toplevel continuation. + ;; Aborts the program when a formatting error occures. This is a null + ;; argument closure to jump to the interpreters toplevel continuation. -(define format:abort (lambda () (error "error in format"))) - -(define (format . args) (monitor (apply format:format args))) + (format:abort (lambda () (error "error in format")))) + + (set! format:error-save format:error) + (set! format:fn-str (make-string format:fn-max)) ; number buffer + (set! format:en-str (make-string format:en-max)) ; exponent buffer + (apply format:format args))) ;; Thanks to Shuji Narazaki (module-set! the-root-module 'format format) - -;; If this is not possible then a continuation is used to recover -;; properly from a format error. In this case format returns #f. - -;(define format:abort -; (lambda () (format:error-continuation #f))) - -;(define format -; (lambda args ; wraps format:format with an error -; (call-with-current-continuation ; continuation -; (lambda (cont) -; (set! format:error-continuation cont) -; (apply format:format args))))) - -;eof From 5dc1ba739f4ba3c13e06bceaf414c863d26f4d54 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Mon, 15 Sep 2003 13:38:07 +0000 Subject: [PATCH 099/109] *** empty log message *** --- ice-9/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index 20e62b71d..c3fcf3039 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -1,3 +1,8 @@ +2003-09-15 Marius Vollmer + + * format.scm (format): Rewritten as a big letrec to make it + reentrant. No mutex is necessary. Thanks to Clinton Ebadi! + 2003-09-13 Kevin Ryde * boot-9.scm (file-exists?): Use stat rather than access?, so as to From f319727482032c70babda70d3f8f813f449437ed Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Sep 2003 22:29:32 +0000 Subject: [PATCH 100/109] Add another comment to: (file-exists?): Use stat rather than access?, ... --- ice-9/boot-9.scm | 1 + 1 file changed, 1 insertion(+) diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm index 5ec9b3234..b06c34484 100644 --- a/ice-9/boot-9.scm +++ b/ice-9/boot-9.scm @@ -407,6 +407,7 @@ (if (provided? 'socket) (primitive-load-path "ice-9/networking.scm")) +;; For reference, Emacs file-exists-p uses stat in this same way. ;; ENHANCE-ME: Catching an exception from stat is a bit wasteful, do this in ;; C where all that's needed is to inspect the return from stat(). (define file-exists? From cd56b181925ce3b46fda87eefc69eb34316c6845 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Mon, 15 Sep 2003 22:47:27 +0000 Subject: [PATCH 101/109] Fix a grammatical typo in my last entry. --- ice-9/ChangeLog | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog index c3fcf3039..210613912 100644 --- a/ice-9/ChangeLog +++ b/ice-9/ChangeLog @@ -7,7 +7,7 @@ * boot-9.scm (file-exists?): Use stat rather than access?, so as to follow the effective UID/GID not the real ID. file-exists? is - normally be used as a prelude to opening or some other operation, and + normally used as a prelude to opening or some other operation, and it's the effective ID which will apply there. Emacs file-exists-p uses stat, presumably for the the same reason. From e17d318faaf4f9674e81b9ee883707b0a57a83af Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 16 Sep 2003 17:37:56 +0000 Subject: [PATCH 102/109] This set of patches eliminates the dependency between the implementation of evaluator specific memoization codes and special constants like #f, '() etc. ('flags'), which are not evaluator specific. The goal is to remove definitions of evaluator memoization codes completely from the public interface. This will make it possible to experiment more freely with optimizations of guile's internal representation of memoized code. * objects.c (scm_class_of): Eliminate dependency on SCM_ISYMNUM. * print.c (iflagnames): New array, holding the printed names of guile's special constants ('flags'). (scm_isymnames): Now holds only the printed names of the memoization codes. (scm_iprin1): Separate the handling of memoization codes and guile's special constants. * tags.h (scm_tc9_flag, SCM_ITAG9, SCM_MAKE_ITAG9, SCM_ITAG9_DATA, SCM_IFLAGNUM): new (scm_tc8_char, scm_tc8_iloc, SCM_BOOL_F, SCM_BOOL_T, SCM_UNDEFINED, SCM_EOF_VAL, SCM_EOL, SCM_UNSPECIFIED, SCM_UNBOUND, SCM_ELISP_NIL, SCM_IM_DISPATCH, SCM_IM_SLOT_REF, SCM_IM_SLOT_SET_X, SCM_IM_DELAY, SCM_IM_FUTURE, SCM_IM_CALL_WITH_VALUES, SCM_IM_NIL_COND, SCM_IM_BIND): Changed values. (SCM_IFLAGP): SCM_IFLAGP now only tests for flags. (SCM_IFLAGP, SCM_MAKIFLAG, SCM_IFLAGNUM): Generalized to use the tc9 macros and scm_tc9_flag. --- libguile/ChangeLog | 36 ++++++++++++++ libguile/objects.c | 17 ++----- libguile/print.c | 59 +++++++++++++--------- libguile/tags.h | 119 ++++++++++++++++++++++++--------------------- 4 files changed, 139 insertions(+), 92 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index f6b6c99ed..60f3bcd58 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,39 @@ +2003-09-16 Dirk Herrmann + + This set of patches eliminates the dependency between the + implementation of evaluator specific memoization codes and special + constants like #f, '() etc. ('flags'), which are not evaluator + specific. The goal is to remove definitions of evaluator + memoization codes completely from the public interface. This will + make it possible to experiment more freely with optimizations of + guile's internal representation of memoized code. + + * objects.c (scm_class_of): Eliminate dependency on SCM_ISYMNUM. + + * print.c (iflagnames): New array, holding the printed names of + guile's special constants ('flags'). + + (scm_isymnames): Now holds only the printed names of the + memoization codes. + + (scm_iprin1): Separate the handling of memoization codes and + guile's special constants. + + * tags.h (scm_tc9_flag, SCM_ITAG9, SCM_MAKE_ITAG9, SCM_ITAG9_DATA, + SCM_IFLAGNUM): new + + (scm_tc8_char, scm_tc8_iloc, SCM_BOOL_F, SCM_BOOL_T, + SCM_UNDEFINED, SCM_EOF_VAL, SCM_EOL, SCM_UNSPECIFIED, SCM_UNBOUND, + SCM_ELISP_NIL, SCM_IM_DISPATCH, SCM_IM_SLOT_REF, + SCM_IM_SLOT_SET_X, SCM_IM_DELAY, SCM_IM_FUTURE, + SCM_IM_CALL_WITH_VALUES, SCM_IM_NIL_COND, SCM_IM_BIND): Changed + values. + + (SCM_IFLAGP): SCM_IFLAGP now only tests for flags. + + (SCM_IFLAGP, SCM_MAKIFLAG, SCM_IFLAGNUM): Generalized to use the + tc9 macros and scm_tc9_flag. + 2003-09-15 Marius Vollmer * posix.c (scm_setgroups): Check that the gid list is not too diff --git a/libguile/objects.c b/libguile/objects.c index 0f4443cd8..be9481c9a 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -71,19 +71,12 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, case scm_tc3_imm24: if (SCM_CHARP (x)) return scm_class_char; + else if (SCM_BOOLP (x)) + return scm_class_boolean; + else if (SCM_NULLP (x)) + return scm_class_null; else - { - switch (SCM_ISYMNUM (x)) - { - case SCM_ISYMNUM (SCM_BOOL_F): - case SCM_ISYMNUM (SCM_BOOL_T): - return scm_class_boolean; - case SCM_ISYMNUM (SCM_EOL): - return scm_class_null; - default: - return scm_class_unknown; - } - } + return scm_class_unknown; case scm_tc3_cons: switch (SCM_TYP7 (x)) diff --git a/libguile/print.c b/libguile/print.c index af297941d..8b9c506be 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -49,9 +49,29 @@ * This table must agree with the declarations in scm.h: {Immediate Symbols}. */ +/* This table must agree with the list of flags in tags.h. */ +static const char *iflagnames[] = +{ + "#f", + "#t", + "#", + "#", + "()", + "#", + + /* Unbound slot marker for GOOPS. For internal use in GOOPS only. */ + "#", + + /* Elisp nil value. This is its Scheme name; whenever it's printed in + * Elisp, it should appear as the symbol `nil'. */ + "#nil" +}; + +/* This table must agree with the list of SCM_IM_ constants in tags.h */ char *scm_isymnames[] = { - /* This table must agree with the list of SCM_IM_ constants in tags.h */ + /* Short instructions */ + "#@and", "#@begin", "#@case", @@ -65,39 +85,23 @@ char *scm_isymnames[] = "#@or", "#@quote", "#@set!", + + + /* Long instructions */ + "#@define", "#@apply", "#@call-with-current-continuation", - - /* user visible ISYMS */ - /* other keywords */ - /* Flags */ - - "#f", - "#t", - "#", - "#", - "()", - "#", "#@dispatch", "#@slot-ref", "#@slot-set!", - - /* Multi-language support */ - - "#@nil-cond", - "#@bind", - "#@delay", "#@future", "#@call-with-values", - "#", - - /* Elisp nil value. This is its Scheme name; whenever it's printed - in Elisp, it should appear as the symbol `nil'. */ - - "#nil" + /* Multi-language support */ + "#@nil-cond", + "#@bind" }; scm_t_option scm_print_opts[] = { @@ -434,8 +438,15 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc (i, port); } else if (SCM_IFLAGP (exp) + && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) + { + scm_puts (iflagnames [SCM_IFLAGNUM (exp)], port); + } + else if (SCM_ISYMP (exp) && ((size_t) SCM_ISYMNUM (exp) < (sizeof scm_isymnames / sizeof (char *)))) + { scm_puts (SCM_ISYMCHARS (exp), port); + } else if (SCM_ILOCP (exp)) { scm_puts ("#@", port); diff --git a/libguile/tags.h b/libguile/tags.h index 4aa8764e7..bc53ff23d 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -317,9 +317,9 @@ typedef unsigned long scm_t_bits; * first dispatch is based on the tc7-code. The second * dispatch is based on the actual byte code that is extracted * from the upper bits. - * x1-1110-100: characters with x as their least significant bit - * 10-1110-100: various constants ('flags') - * x1-1111-100: evaluator byte codes ('ilocs') + * x1-1110-100: evaluator byte codes ('ilocs') + * x1-1111-100: characters with x as their least significant bit + * 10-1111-100: various constants ('flags') * * * Summary of type codes on the heap @@ -493,44 +493,71 @@ typedef unsigned long scm_t_bits; enum scm_tags { - scm_tc8_char = 0xf4, - scm_tc8_iloc = 0xfc + scm_tc8_iloc = 0xf4, + scm_tc8_char = 0xfc, + scm_tc9_flag = 0x17c }; #define SCM_ITAG8(X) (SCM_UNPACK (X) & 0xff) #define SCM_MAKE_ITAG8(X, TAG) SCM_PACK (((X) << 8) + TAG) #define SCM_ITAG8_DATA(X) (SCM_UNPACK (X) >> 8) +#define SCM_ITAG9(X) (SCM_UNPACK (X) & 0x1ff) +#define SCM_MAKE_ITAG9(X, TAG) SCM_PACK (((X) << 9) + TAG) +#define SCM_ITAG9_DATA(X) (SCM_UNPACK (X) >> 9) + -/* Immediate Symbols, Special Symbols, Flags (various constants). - */ +/* Flags (various constants and special objects). The indices of the flags + * must agree with the declarations in print.c: iflagnames. */ + +#define SCM_IFLAGP(n) (SCM_ITAG9 (n) == scm_tc9_flag) +#define SCM_MAKIFLAG(n) SCM_MAKE_ITAG9 ((n), scm_tc9_flag) +#define SCM_IFLAGNUM(n) (SCM_ITAG9_DATA (n)) + +#define SCM_BOOL_F SCM_MAKIFLAG (0) +#define SCM_BOOL_T SCM_MAKIFLAG (1) +#define SCM_UNDEFINED SCM_MAKIFLAG (2) +#define SCM_EOF_VAL SCM_MAKIFLAG (3) +#define SCM_EOL SCM_MAKIFLAG (4) +#define SCM_UNSPECIFIED SCM_MAKIFLAG (5) + +/* When a variable is unbound this is marked by the SCM_UNDEFINED + * value. The following is an unbound value which can be handled on + * the Scheme level, i.e., it can be stored in and retrieved from a + * Scheme variable. This value is only intended to mark an unbound + * slot in GOOPS. It is needed now, but we should probably rewrite + * the code which handles this value in C so that SCM_UNDEFINED can be + * used instead. It is not ideal to let this kind of unique and + * strange values loose on the Scheme level. */ +#define SCM_UNBOUND SCM_MAKIFLAG (6) + +/* The Elisp nil value. */ +#define SCM_ELISP_NIL SCM_MAKIFLAG (7) + + +#define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) + + +/* Short instructions ('special symbols'), long instructions ('immediate + * symbols'). The indices of the SCM_IM_ symbols must agree with the + * declarations in print.c: scm_isymnames. */ + +#define SCM_MAKSPCSYM(n) SCM_PACK (((n) << 9) + ((n) << 3) + 4L) +#define SCM_MAKISYM(n) SCM_PACK (((n) << 9) + 0x6cL) /* SCM_ISYMP tests for ISPCSYM and ISYM */ #define SCM_ISYMP(n) ((0x187 & SCM_UNPACK (n)) == 4) - -/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */ -#define SCM_IFLAGP(n) ((0x87 & SCM_UNPACK (n)) == 4) #define SCM_ISYMNUM(n) (SCM_UNPACK (n) >> 9) -#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)]) -#define SCM_MAKSPCSYM(n) SCM_PACK (((n) << 9) + ((n) << 3) + 4L) -#define SCM_MAKISYM(n) SCM_PACK (((n) << 9) + 0x6cL) -#define SCM_MAKIFLAG(n) SCM_PACK (((n) << 9) + 0x174L) - SCM_API char *scm_isymnames[]; /* defined in print.c */ - -/* This table must agree with the declarations - * in print.c: {Names of immediate symbols}. - * - * These are used only in eval but their values - * have to be allocated here. - */ +#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)]) /* Evaluator bytecodes (short instructions): These are uniquely identified by * their tc7 value. This makes it possible for the evaluator to dispatch on * them in one step. However, the type system allows for at most 13 short * instructions. Consequently, the most frequent instructions are chosen to - * be represented as short instructions. */ + * be represented as short instructions. These constants are used only in + * eval but their values have to be allocated here. */ #define SCM_IM_AND SCM_MAKSPCSYM (0) #define SCM_IM_BEGIN SCM_MAKSPCSYM (1) @@ -546,11 +573,14 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_QUOTE SCM_MAKSPCSYM (11) #define SCM_IM_SET_X SCM_MAKSPCSYM (12) + /* Evaluator bytecodes (long instructions): All these share a common tc7 - * value. Thus, the evaluator needs to dispatch on them in two steps. */ + * value. Thus, the evaluator needs to dispatch on them in two steps. These + * constants are used only in eval but their values have to be allocated + * here. */ /* Evaluator bytecode for (define ...) statements. We make it a long - * instruction since the executor will see this bytecode only for a very + * instruction since the evaluator will see this bytecode only for a very * limited number of times, namely once for every top-level and internal * definition: Top-level definitions are only executed once and internal * definitions are converted to letrec expressions. */ @@ -558,40 +588,17 @@ SCM_API char *scm_isymnames[]; /* defined in print.c */ #define SCM_IM_APPLY SCM_MAKISYM (14) #define SCM_IM_CONT SCM_MAKISYM (15) -#define SCM_BOOL_F SCM_MAKIFLAG (16) -#define SCM_BOOL_T SCM_MAKIFLAG (17) -#define SCM_UNDEFINED SCM_MAKIFLAG (18) -#define SCM_EOF_VAL SCM_MAKIFLAG (19) -#define SCM_EOL SCM_MAKIFLAG (20) -#define SCM_UNSPECIFIED SCM_MAKIFLAG (21) -#define SCM_IM_DISPATCH SCM_MAKISYM (22) -#define SCM_IM_SLOT_REF SCM_MAKISYM (23) -#define SCM_IM_SLOT_SET_X SCM_MAKISYM (24) +#define SCM_IM_DISPATCH SCM_MAKISYM (16) +#define SCM_IM_SLOT_REF SCM_MAKISYM (17) +#define SCM_IM_SLOT_SET_X SCM_MAKISYM (18) +#define SCM_IM_DELAY SCM_MAKISYM (19) +#define SCM_IM_FUTURE SCM_MAKISYM (20) +#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (21) /* Multi-language support */ -#define SCM_IM_NIL_COND SCM_MAKISYM (25) -#define SCM_IM_BIND SCM_MAKISYM (26) - -#define SCM_IM_DELAY SCM_MAKISYM (27) -#define SCM_IM_FUTURE SCM_MAKISYM (28) -#define SCM_IM_CALL_WITH_VALUES SCM_MAKISYM (29) - -/* When a variable is unbound this is marked by the SCM_UNDEFINED - * value. The following is an unbound value which can be handled on - * the Scheme level, i.e., it can be stored in and retrieved from a - * Scheme variable. This value is only intended to mark an unbound - * slot in GOOPS. It is needed now, but we should probably rewrite - * the code which handles this value in C so that SCM_UNDEFINED can be - * used instead. It is not ideal to let this kind of unique and - * strange values loose on the Scheme level. - */ -#define SCM_UNBOUND SCM_MAKIFLAG (30) - -#define SCM_UNBNDP(x) (SCM_EQ_P ((x), SCM_UNDEFINED)) - -/* The Elisp nil value. */ -#define SCM_ELISP_NIL SCM_MAKIFLAG (31) +#define SCM_IM_NIL_COND SCM_MAKISYM (22) +#define SCM_IM_BIND SCM_MAKISYM (23) From 2d99b584ac6cf195e1c52f28a819c6937bdd9293 Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 16 Sep 2003 21:18:26 +0000 Subject: [PATCH 103/109] (scm_current_time): 'time' does not set errno so don't use SCM_SYSERROR for reporting errors. --- libguile/stime.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/libguile/stime.c b/libguile/stime.c index 1d9265e96..e792eba08 100644 --- a/libguile/stime.c +++ b/libguile/stime.c @@ -190,7 +190,7 @@ SCM_DEFINE (scm_current_time, "current-time", 0, 0, 0, SCM_DEFER_INTS; if ((timv = time (0)) == -1) - SCM_SYSERROR; + SCM_MISC_ERROR ("current time not available", SCM_EOL); SCM_ALLOW_INTS; return scm_long2num((long) timv); } From 859b6b2fff3b9f1626dafef739d991ebb7bf325a Mon Sep 17 00:00:00 2001 From: Marius Vollmer Date: Tue, 16 Sep 2003 21:21:28 +0000 Subject: [PATCH 104/109] *** empty log message *** --- libguile/ChangeLog | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 60f3bcd58..7736e4557 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,8 @@ +2003-09-16 Marius Vollmer + + * stime.c (scm_current_time): 'time' does not set errno so don't + use SCM_SYSERROR for reporting errors. + 2003-09-16 Dirk Herrmann This set of patches eliminates the dependency between the From 47ae1f0ecaded1a0a094db3f7ec9687dec71f72d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Wed, 17 Sep 2003 21:03:26 +0000 Subject: [PATCH 105/109] * libguile/numbers.c (scm_bigequal): Fixed. * test-suite/tests/numbers.test (equal?): Added tests. * test-suite/tests/numbers.test (=): Fixed and added some bignum related tests. --- libguile/ChangeLog | 5 ++- libguile/numbers.c | 2 +- test-suite/ChangeLog | 7 +++++ test-suite/tests/numbers.test | 59 ++++++++++++++++++++++++++++++++++- 4 files changed, 70 insertions(+), 3 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 7736e4557..3f9667804 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,7 @@ +2003-09-17 Dirk Herrmann + + * numbers.c (scm_bigequal): Fixed. + 2003-09-16 Marius Vollmer * stime.c (scm_current_time): 'time' does not set errno so don't @@ -556,7 +560,6 @@ yyset_debug, yylex_destroy): Added prototypes (otherwise we'll get a compilation error if error-on-warning is enabled). ->>>>>>> 1.1883 2003-05-17 Marius Vollmer * c-tokenize.lex: Gobble up complete lines after a '#'. This diff --git a/libguile/numbers.c b/libguile/numbers.c index a8fb84646..661622205 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2522,7 +2522,7 @@ scm_make_complex (double x, double y) SCM scm_bigequal (SCM x, SCM y) { - int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (x)); + int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); scm_remember_upto_here_2 (x, y); return SCM_BOOL (0 == result); } diff --git a/test-suite/ChangeLog b/test-suite/ChangeLog index 7ff206a59..35500f904 100644 --- a/test-suite/ChangeLog +++ b/test-suite/ChangeLog @@ -1,3 +1,10 @@ +2003-09-17 Dirk Herrmann + + * tests/numbers.test (equal?): Added tests. + + * tests/numbers.test (=): Fixed and added some bignum related + tests. + 2003-08-30 Kevin Ryde * tests/numbers.test (logcount): Add tests. diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index 8ba975964..0040bd692 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1146,6 +1146,61 @@ (pass-if (not (inexact? (lambda () #t)))) (pass-if (not (inexact? (current-input-port))))) +;;; +;;; equal? +;;; + +(with-test-prefix "equal?" + (pass-if (documented? equal?)) + (pass-if (equal? 0 0)) + (pass-if (equal? 7 7)) + (pass-if (equal? -7 -7)) + (pass-if (equal? (+ 1 fixnum-max) (+ 1 fixnum-max))) + (pass-if (equal? (- fixnum-min 1) (- fixnum-min 1))) + (pass-if (not (equal? 0 1))) + (pass-if (not (equal? fixnum-max (+ 1 fixnum-max)))) + (pass-if (not (equal? (+ 1 fixnum-max) fixnum-max))) + (pass-if (not (equal? (+ 1 fixnum-max) (+ 2 fixnum-max)))) + (pass-if (not (equal? fixnum-min (- fixnum-min 1)))) + (pass-if (not (equal? (- fixnum-min 1) fixnum-min))) + (pass-if (not (equal? (- fixnum-min 1) (- fixnum-min 2)))) + (pass-if (not (equal? (+ fixnum-max 1) (- fixnum-min 1)))) + + (pass-if (not (equal? (ash 1 256) +inf.0))) + (pass-if (not (equal? +inf.0 (ash 1 256)))) + (pass-if (not (equal? (ash 1 256) -inf.0))) + (pass-if (not (equal? -inf.0 (ash 1 256)))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating Inf as 2^1024, make + ;; sure we've avoided that + (pass-if (not (equal? (ash 1 1024) +inf.0))) + (pass-if (not (equal? +inf.0 (ash 1 1024)))) + (pass-if (not (equal? (- (ash 1 1024)) -inf.0))) + (pass-if (not (equal? -inf.0 (- (ash 1 1024))))) + + (pass-if (not (equal? +nan.0 +nan.0))) + (pass-if (not (equal? 0 +nan.0))) + (pass-if (not (equal? +nan.0 0))) + (pass-if (not (equal? 1 +nan.0))) + (pass-if (not (equal? +nan.0 1))) + (pass-if (not (equal? -1 +nan.0))) + (pass-if (not (equal? +nan.0 -1))) + + (pass-if (not (equal? (ash 1 256) +nan.0))) + (pass-if (not (equal? +nan.0 (ash 1 256)))) + (pass-if (not (equal? (- (ash 1 256)) +nan.0))) + (pass-if (not (equal? +nan.0 (- (ash 1 256))))) + + (pass-if (not (equal? (ash 1 8192) +nan.0))) + (pass-if (not (equal? +nan.0 (ash 1 8192)))) + (pass-if (not (equal? (- (ash 1 8192)) +nan.0))) + (pass-if (not (equal? +nan.0 (- (ash 1 8192))))) + + ;; in gmp prior to 4.2, mpz_cmp_d ended up treating NaN as 3*2^1023, make + ;; sure we've avoided that + (pass-if (not (equal? (ash 3 1023) +nan.0))) + (pass-if (not (equal? +nan.0 (ash 3 1023))))) + ;;; ;;; = ;;; @@ -1156,12 +1211,14 @@ (pass-if (= 7 7)) (pass-if (= -7 -7)) (pass-if (= (+ 1 fixnum-max) (+ 1 fixnum-max))) - (pass-if (= (- 1 fixnum-min) (- 1 fixnum-min))) + (pass-if (= (- fixnum-min 1) (- fixnum-min 1))) (pass-if (not (= 0 1))) (pass-if (not (= fixnum-max (+ 1 fixnum-max)))) (pass-if (not (= (+ 1 fixnum-max) fixnum-max))) + (pass-if (not (= (+ 1 fixnum-max) (+ 2 fixnum-max)))) (pass-if (not (= fixnum-min (- fixnum-min 1)))) (pass-if (not (= (- fixnum-min 1) fixnum-min))) + (pass-if (not (= (- fixnum-min 1) (- fixnum-min 2)))) (pass-if (not (= (+ fixnum-max 1) (- fixnum-min 1)))) (pass-if (not (= (ash 1 256) +inf.0))) From 29c4382afda07debaef4f5d2534f5272bca15fdd Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 Sep 2003 20:18:17 +0000 Subject: [PATCH 106/109] * numbers.c (scm_make_complex), gc-card.c (scm_i_sweep_card): Use sizeof (scm_t_complex) to determine the memory size of the malloc'd area for complex numbers. --- libguile/ChangeLog | 6 ++++++ libguile/gc-card.c | 3 ++- libguile/numbers.c | 2 +- 3 files changed, 9 insertions(+), 2 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 3f9667804..2f6c4f82f 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,9 @@ +2003-09-18 Dirk Herrmann + + * numbers.c (scm_make_complex), gc-card.c (scm_i_sweep_card): Use + sizeof (scm_t_complex) to determine the memory size of the + malloc'd area for complex numbers. + 2003-09-17 Dirk Herrmann * numbers.c (scm_bigequal): Fixed. diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 3939417d3..26fd425d5 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -21,6 +21,7 @@ #include "libguile/_scm.h" #include "libguile/eval.h" +#include "libguile/numbers.h" #include "libguile/stime.h" #include "libguile/stackchk.h" #include "libguile/struct.h" @@ -238,7 +239,7 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) /* nothing else to do here since the mpz is in a double cell */ break; case scm_tc16_complex: - scm_gc_free (SCM_COMPLEX_MEM (scmptr), 2*sizeof (double), + scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex), "complex"); break; default: diff --git a/libguile/numbers.c b/libguile/numbers.c index 661622205..472866bd7 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -2510,7 +2510,7 @@ scm_make_complex (double x, double y) else { SCM z; - SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), + SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex), "complex")); SCM_COMPLEX_REAL (z) = x; SCM_COMPLEX_IMAG (z) = y; From 534c55a97d9860059a2d2042263cce3cad364b2c Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Thu, 18 Sep 2003 20:55:40 +0000 Subject: [PATCH 107/109] This set of patches introduces a new tc7 code scm_tc7_number for numbers. Bignums, reals and complex numbers are turned from smobs into subtypes of scm_tc7_number. * tags.h (scm_tc7_number): New. * eq.c (scm_equal_p), eval.c (SCM_CEVAL), evalext.c (scm_self_evaluating_p), gc-card.c (scm_i_sweep_card), gc-mark.c (scm_gc_mark_dependencies), goops.c (create_smob_classes), hash.c (scm_hasher), numbers.c, numbers.h (SCM_NUMP), objects.c (scm_class_of), print.c (scm_iprin1), smob.c (scm_smob_prehistory): Don't handle bignums, reals and complex numbers as subtypes of scm_tc7_smob any more. * numbers.h, tags.h (scm_tc16_big, scm_tc16_real, scm_tc16_complex): Moved definitions from tags.h to numbers.h. --- libguile/ChangeLog | 19 +++++++++++++++++++ libguile/eq.c | 10 ++++++++++ libguile/eval.c | 1 + libguile/evalext.c | 1 + libguile/gc-card.c | 24 +++++++++++++++--------- libguile/gc-mark.c | 7 +++---- libguile/goops.c | 3 --- libguile/hash.c | 7 +++++-- libguile/numbers.c | 2 +- libguile/numbers.h | 12 +++++++++++- libguile/objects.c | 9 +++++++++ libguile/print.c | 13 +++++++++++++ libguile/smob.c | 16 ++-------------- libguile/tags.h | 25 ++++++++----------------- 14 files changed, 98 insertions(+), 51 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2f6c4f82f..0c1445e19 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,22 @@ +2003-09-18 Dirk Herrmann + + This set of patches introduces a new tc7 code scm_tc7_number for + numbers. Bignums, reals and complex numbers are turned from smobs + into subtypes of scm_tc7_number. + + * tags.h (scm_tc7_number): New. + + * eq.c (scm_equal_p), eval.c (SCM_CEVAL), evalext.c + (scm_self_evaluating_p), gc-card.c (scm_i_sweep_card), gc-mark.c + (scm_gc_mark_dependencies), goops.c (create_smob_classes), hash.c + (scm_hasher), numbers.c, numbers.h (SCM_NUMP), objects.c + (scm_class_of), print.c (scm_iprin1), smob.c + (scm_smob_prehistory): Don't handle bignums, reals and complex + numbers as subtypes of scm_tc7_smob any more. + + * numbers.h, tags.h (scm_tc16_big, scm_tc16_real, + scm_tc16_complex): Moved definitions from tags.h to numbers.h. + 2003-09-18 Dirk Herrmann * numbers.c (scm_make_complex), gc-card.c (scm_i_sweep_card): Use diff --git a/libguile/eq.c b/libguile/eq.c index 676df3ed1..06467c486 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -166,6 +166,16 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, { default: break; + case scm_tc7_number: + switch SCM_TYP16 (x) + { + case scm_tc16_big: + return scm_bigequal (x, y); + case scm_tc16_real: + return scm_real_equalp (x, y); + case scm_tc16_complex: + return scm_complex_equalp (x, y); + } case scm_tc7_vector: case scm_tc7_wvect: return scm_vector_equal_p (x, y); diff --git a/libguile/eval.c b/libguile/eval.c index f4ea80630..d52c84360 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2790,6 +2790,7 @@ dispatch: case scm_tc7_llvect: #endif #endif + case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: case scm_tcs_closures: diff --git a/libguile/evalext.c b/libguile/evalext.c index 4db0a8030..0590f48c9 100644 --- a/libguile/evalext.c +++ b/libguile/evalext.c @@ -113,6 +113,7 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_llvect: #endif #endif + case scm_tc7_number: case scm_tc7_string: case scm_tc7_smob: case scm_tc7_cclo: diff --git a/libguile/gc-card.c b/libguile/gc-card.c index 26fd425d5..432ead5a9 100644 --- a/libguile/gc-card.c +++ b/libguile/gc-card.c @@ -173,6 +173,21 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) "vector"); break; #endif + case scm_tc7_number: + switch SCM_TYP16 (scmptr) + { + case scm_tc16_real: + break; + case scm_tc16_big: + mpz_clear (SCM_I_BIG_MPZ (scmptr)); + /* nothing else to do here since the mpz is in a double cell */ + break; + case scm_tc16_complex: + scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex), + "complex"); + break; + } + break; case scm_tc7_string: scm_gc_free (SCM_STRING_CHARS (scmptr), SCM_STRING_LENGTH (scmptr) + 1, "string"); @@ -232,15 +247,6 @@ scm_i_sweep_card (scm_t_cell * p, SCM *free_list, scm_t_heap_segment*seg) switch SCM_TYP16 (scmptr) { case scm_tc_free_cell: - case scm_tc16_real: - break; - case scm_tc16_big: - mpz_clear (SCM_I_BIG_MPZ (scmptr)); - /* nothing else to do here since the mpz is in a double cell */ - break; - case scm_tc16_complex: - scm_gc_free (SCM_COMPLEX_MEM (scmptr), sizeof (scm_t_complex), - "complex"); break; default: { diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c index 53d57b67f..994d3aa88 100644 --- a/libguile/gc-mark.c +++ b/libguile/gc-mark.c @@ -280,6 +280,9 @@ scm_gc_mark_dependencies (SCM p) case scm_tc7_string: break; + case scm_tc7_number: + break; + case scm_tc7_wvect: SCM_SET_WVECT_GC_CHAIN (ptr, scm_weak_vectors); scm_weak_vectors = ptr; @@ -374,10 +377,6 @@ scm_gc_mark_dependencies (SCM p) * on the C stack points into guile's heap and is scanned during * conservative marking. */ break; - case scm_tc16_big: - case scm_tc16_real: - case scm_tc16_complex: - break; default: i = SCM_SMOBNUM (ptr); #if (SCM_DEBUG_CELL_ACCESSES == 1) diff --git a/libguile/goops.c b/libguile/goops.c index 1a2bb7304..44da20efe 100644 --- a/libguile/goops.c +++ b/libguile/goops.c @@ -2516,9 +2516,6 @@ create_smob_classes (void) for (i = 0; i < 255; ++i) scm_smob_class[i] = 0; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_big)] = scm_class_integer; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_real)] = scm_class_real; - scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_complex)] = scm_class_complex; scm_smob_class[SCM_TC2SMOBNUM (scm_tc16_keyword)] = scm_class_keyword; for (i = 0; i < scm_numsmob; ++i) diff --git a/libguile/hash.c b/libguile/hash.c index 26c4fcd8e..8801a7a28 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -96,11 +96,11 @@ scm_hasher(SCM obj, unsigned long n, size_t d) default: return 263 % n; case scm_tc7_smob: + return 263 % n; + case scm_tc7_number: switch SCM_TYP16 (obj) { case scm_tc16_big: return SCM_INUM (scm_modulo (obj, SCM_MAKINUM (n))); - default: - return 263 % n; case scm_tc16_real: { double r = SCM_REAL_VALUE (obj); @@ -110,9 +110,12 @@ scm_hasher(SCM obj, unsigned long n, size_t d) return SCM_INUM (scm_modulo (obj, SCM_MAKINUM (n))); } } + /* Fall through */ case scm_tc16_complex: obj = scm_number_to_string (obj, SCM_MAKINUM (10)); + /* Fall through */ } + /* Fall through */ case scm_tc7_string: return scm_string_hash (SCM_STRING_UCHARS (obj), SCM_STRING_LENGTH (obj)) % n; case scm_tc7_symbol: diff --git a/libguile/numbers.c b/libguile/numbers.c index 472866bd7..6f9c60622 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -76,7 +76,7 @@ #define SCM_I_NUMTAG(x) \ (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \ : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \ - : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) ? SCM_TYP16(x) \ + : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \ : SCM_I_NUMTAG_NOTNUM))) */ diff --git a/libguile/numbers.h b/libguile/numbers.h index 4172c703e..10e8eddc9 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -121,6 +121,16 @@ /* Numbers */ + +/* Note that scm_tc16_real and scm_tc16_complex are given tc16-codes that only + * differ in one bit: This way, checking if an object is an inexact number can + * be done quickly (using the TYP16S macro). */ + +/* Number subtype 1 to 3 (note the dependency on the predicate SCM_NUMP) */ +#define scm_tc16_big (scm_tc7_number + 1 * 256L) +#define scm_tc16_real (scm_tc7_number + 2 * 256L) +#define scm_tc16_complex (scm_tc7_number + 3 * 256L) + #define SCM_INEXACTP(x) (!SCM_IMP (x) && SCM_TYP16S (x) == scm_tc16_real) #define SCM_REALP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_real) #define SCM_COMPLEXP(x) (!SCM_IMP (x) && SCM_TYP16 (x) == scm_tc16_complex) @@ -136,7 +146,7 @@ #define SCM_NUMBERP(x) (SCM_INUMP(x) || SCM_NUMP(x)) #define SCM_NUMP(x) (!SCM_IMP(x) \ - && (0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_smob) + && (0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) diff --git a/libguile/objects.c b/libguile/objects.c index be9481c9a..12ee5a9c0 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -102,6 +102,15 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, return scm_class_vector; case scm_tc7_string: return scm_class_string; + case scm_tc7_number: + switch SCM_TYP16 (x) { + case scm_tc16_big: + return scm_class_integer; + case scm_tc16_real: + return scm_class_real; + case scm_tc16_complex: + return scm_class_complex; + } case scm_tc7_asubr: case scm_tc7_subr_0: case scm_tc7_subr_1: diff --git a/libguile/print.c b/libguile/print.c index 8b9c506be..50b969e24 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -516,6 +516,19 @@ scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_putc ('>', port); } break; + case scm_tc7_number: + switch SCM_TYP16 (exp) { + case scm_tc16_big: + scm_bigprint (exp, port, pstate); + break; + case scm_tc16_real: + scm_print_real (exp, port, pstate); + break; + case scm_tc16_complex: + scm_print_complex (exp, port, pstate); + break; + } + break; case scm_tc7_string: if (SCM_WRITINGP (pstate)) { diff --git a/libguile/smob.c b/libguile/smob.c index 6b3001ed8..c73b2a9ca 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -448,7 +448,7 @@ scm_make_smob (scm_t_bits tc) } -/* {Initialization for i/o types, float, bignum, the type of free cells} +/* {Initialization for the type of free cells} */ static int @@ -491,21 +491,9 @@ scm_smob_prehistory () scm_smobs[i].gsubr_type = 0; } - /* WARNING: These scm_make_smob_type calls must be done in this order */ + /* WARNING: This scm_make_smob_type call must be done first. */ tc = scm_make_smob_type ("free", 0); scm_set_smob_print (tc, free_print); - - tc = scm_make_smob_type ("big", 0); /* freed in gc */ - scm_set_smob_print (tc, scm_bigprint); - scm_set_smob_equalp (tc, scm_bigequal); - - tc = scm_make_smob_type ("real", 0); /* freed in gc */ - scm_set_smob_print (tc, scm_print_real); - scm_set_smob_equalp (tc, scm_real_equalp); - - tc = scm_make_smob_type ("complex", 0); /* freed in gc */ - scm_set_smob_print (tc, scm_print_complex); - scm_set_smob_equalp (tc, scm_complex_equalp); } /* diff --git a/libguile/tags.h b/libguile/tags.h index bc53ff23d..aeff81300 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -353,21 +353,17 @@ typedef unsigned long scm_t_bits; * cases. Thus, their tc7-codes are chosen to only differ in one bit. This * makes it possible to check an object at the same time for being a vector * or a weak vector by comparing its tc7 code with that bit masked (using - * the TYP7S macro). Two more special tc7-codes are of interest: ports and - * smobs in fact each represent collections of types, which are subdivided - * using tc16-codes. + * the TYP7S macro). Three more special tc7-codes are of interest: + * numbers, ports and smobs in fact each represent collections of types, + * which are subdivided using tc16-codes. * * tc16 (for tc7==scm_tc7_smob): * The largest part of the space of smob types is not subdivided in a * predefined way, since smobs can be added arbitrarily by user C code. * However, while Guile also defines a number of smob types throughout, - * there are four smob types for which Guile assumes that they are declared - * first and thus get known-in-advance tc16-codes. These are - * scm_tc_free_cell, scm_tc16_big, scm_tc16_real and scm_tc16_complex. The - * reason of requiring fixed tc16-codes for these types is performance. For - * the same reason, scm_tc16_real and scm_tc16_complex are given tc16-codes - * that only differ in one bit: This way, checking if an object is an - * inexact number can be done quickly (using the TYP16S macro) + * there is one smob type, namely scm_tc_free_cell, for which Guile assumes + * that it is declared first and thus gets a known-in-advance tc16-code. + * The reason of requiring a fixed tc16-code for this type is performance. */ @@ -425,7 +421,7 @@ typedef unsigned long scm_t_bits; #define scm_tc7_wvect 15 #define scm_tc7_string 21 -/* free 23 */ +#define scm_tc7_number 23 /* Many of the following should be turned * into structs or smobs. We need back some @@ -476,17 +472,12 @@ typedef unsigned long scm_t_bits; #define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag)) -/* Here are the first four smob subtypes. */ +/* Here is the first smob subtype. */ /* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell * the conservative marker not to trace it. */ #define scm_tc_free_cell (scm_tc7_smob + 0 * 256L) -/* Smob type 1 to 3 (note the dependency on the predicate SCM_NUMP) */ -#define scm_tc16_big (scm_tc7_smob + 1 * 256L) -#define scm_tc16_real (scm_tc7_smob + 2 * 256L) -#define scm_tc16_complex (scm_tc7_smob + 3 * 256L) - /* {Immediate Values} */ From a118e0eb5a4654c39157fcfd9c664f925a16a21d Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:01:10 +0000 Subject: [PATCH 108/109] (open-process): Correction to previous fdes closing change, need to watch out for stdin==stderr or stdout==stderr. --- ice-9/popen.scm | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/ice-9/popen.scm b/ice-9/popen.scm index 1e6f30b36..b35e715c3 100644 --- a/ice-9/popen.scm +++ b/ice-9/popen.scm @@ -81,9 +81,8 @@ (= pt-fileno error-fdes))) (close-fdes pt-fileno)))))) - ;; copy the three selected descriptors to the standard - ;; descriptors 0, 1, 2. note that it's possible that - ;; output-fdes or input-fdes is equal to error-fdes. + ;; Copy the three selected descriptors to the standard + ;; descriptors 0, 1, 2, if not already there (cond ((not (= input-fdes 0)) (if (= output-fdes 0) @@ -91,13 +90,17 @@ (if (= error-fdes 0) (set! error-fdes (dup->fdes 0))) (dup2 input-fdes 0) - (close-fdes input-fdes))) - + ;; it's possible input-fdes is error-fdes + (if (not (= input-fdes error-fdes)) + (close-fdes input-fdes)))) + (cond ((not (= output-fdes 1)) (if (= error-fdes 1) (set! error-fdes (dup->fdes 1))) (dup2 output-fdes 1) - (close-fdes output-fdes))) + ;; it's possible output-fdes is error-fdes + (if (not (= output-fdes error-fdes)) + (close-fdes output-fdes)))) (cond ((not (= error-fdes 2)) (dup2 error-fdes 2) From 3e690887f5314e8bdc0d2f1092c8044ec38b2842 Mon Sep 17 00:00:00 2001 From: Kevin Ryde Date: Fri, 19 Sep 2003 01:05:13 +0000 Subject: [PATCH 109/109] New file. --- test-suite/tests/popen.test | 162 ++++++++++++++++++++++++++++++++++++ 1 file changed, 162 insertions(+) create mode 100644 test-suite/tests/popen.test diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test new file mode 100644 index 000000000..33da12f71 --- /dev/null +++ b/test-suite/tests/popen.test @@ -0,0 +1,162 @@ +;;;; popen.test --- exercise ice-9/popen.scm -*- scheme -*- +;;;; +;;;; Copyright 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +(define-module (test-suite test-ice-9-popen) + #:use-module (test-suite lib) + #:use-module (ice-9 popen)) + + +;; read from PORT until eof is reached, return what's read as a string +(define (read-string-to-eof port) + (do ((lst '() (cons c lst)) + (c (read-char port) (read-char port))) + ((eof-object? c) + (list->string (reverse! lst))))) + +;; call (THUNK), with SIGPIPE set to SIG_IGN so that an EPIPE error is +;; generated rather than a SIGPIPE signal +(define (with-epipe thunk) + (dynamic-wind + (lambda () + (sigaction SIGPIPE SIG_IGN)) + thunk + restore-signals)) + + +;; +;; open-input-pipe +;; + +(with-test-prefix "open-input-pipe" + + (pass-if-exception "no args" exception:wrong-num-args + (open-input-pipe)) + + (pass-if "port?" + (port? (open-input-pipe "echo hello"))) + + (pass-if "echo hello" + (string=? "hello\n" (read-string-to-eof (open-input-pipe "echo hello")))) + + ;; exercise file descriptor setups when stdin is the same as stderr + (pass-if "stdin==stderr" + (let ((port (open-file "/dev/null" "r+"))) + (with-input-from-port port + (lambda () + (with-error-to-port port + (lambda () + (open-input-pipe "echo hello")))))) + #t) + + ;; exercise file descriptor setups when stdout is the same as stderr + (pass-if "stdout==stderr" + (let ((port (open-file "/dev/null" "r+"))) + (with-output-to-port port + (lambda () + (with-error-to-port port + (lambda () + (open-input-pipe "echo hello")))))) + #t) + + ;; After the child closes stdout (which it indicates here by writing + ;; "closed" to stderr), the parent should see eof. In Guile 1.6.4 and + ;; earlier a duplicate of stdout existed in the child, meaning eof was not + ;; seen. + (pass-if "no duplicate" + (let* ((pair (pipe)) + (port (with-error-to-port (cdr pair) + (lambda () + (open-input-pipe + "exec 1>/dev/null; echo closed 1>&2; sleep 999"))))) + (read-char (car pair)) ;; wait for child to do its thing + (and (char-ready? port) + (eof-object? (read-char port)))))) + +;; +;; open-output-pipe +;; + +(with-test-prefix "open-output-pipe" + + (pass-if-exception "no args" exception:wrong-num-args + (open-output-pipe)) + + (pass-if "port?" + (port? (open-output-pipe "exit 0"))) + + ;; exercise file descriptor setups when stdout is the same as stderr + (pass-if "stdin==stderr" + (let ((port (open-file "/dev/null" "r+"))) + (with-input-from-port port + (lambda () + (with-error-to-port port + (lambda () + (open-output-pipe "exit 0")))))) + #t) + + ;; exercise file descriptor setups when stdout is the same as stderr + (pass-if "stdout==stderr" + (let ((port (open-file "/dev/null" "r+"))) + (with-output-to-port port + (lambda () + (with-error-to-port port + (lambda () + (open-output-pipe "exit 0")))))) + #t) + + ;; After the child closes stdin (which it indicates here by writing + ;; "closed" to stderr), the parent should see a broken pipe. We setup to + ;; see this as EPIPE (rather than SIGPIPE). In Guile 1.6.4 and earlier a + ;; duplicate of stdin existed in the child, preventing the broken pipe + ;; occurring. + (pass-if "no duplicate" + (with-epipe + (lambda () + (let* ((pair (pipe)) + (port (with-error-to-port (cdr pair) + (lambda () + (open-output-pipe + "exec 0&2; sleep 999"))))) + (read-char (car pair)) ;; wait for child to do its thing + (catch 'system-error + (lambda () + (write-char #\x port) + (force-output port) + #f) + (lambda (key name fmt args errno-list) + (= (car errno-list) EPIPE)))))))) + +;; +;; close-pipe +;; + +(with-test-prefix "open-output-pipe" + + (pass-if-exception "no args" exception:wrong-num-args + (close-pipe)) + + (pass-if "exit 0" + (let ((st (close-pipe (open-output-pipe "exit 0")))) + (and (status:exit-val st) + (= 0 (status:exit-val st))))) + + (pass-if "exit 1" + (let ((st (close-pipe (open-output-pipe "exit 1")))) + (and (status:exit-val st) + (= 1 (status:exit-val st)))))) +